-/* Tool for working with BIF-6809 images.\r// Written by Joel Matthew Rees, Amagasaki, Japan, April 2019,\r// Parts adapted from the author's 32col.c, written 1999.\r// Copyright 1999, 2019, Joel Matthew Rees.\r// Permission granted in advance for all uses\r// with the condition that this copyright and permission notice are retained.\r//\r// BIF-6809 project page: https://osdn.net/projects/bif-6809/\r*/\r\r#include <limits.h>\r#include <stdio.h>\r#include <stdlib.h> /* for EXIT_SUCCESS */\r#include <string.h>\r#include <ctype.h>\r\r\r#define kScreenSize 1024\r#define kScreenWidth 32\r#define kScreenHeight ( kScreenSize / kScreenWidth )\r#define kBufferPlay 3 /* room for CR/LF and NUL */\r#define kBufferWidth ( kScreenWidth + kBufferPlay ) /* Should never be used. */\r\r\r#define TO_SCREEN 1\rconst char kTo_ScreenStr[] = "--to-screens";\r#define TO_EOLN_TEXT 2\rconst char kTo_EOLN_textStr[] = "--to-eoln-text";\r\rconst char kBlockSizeStr[] = "-size";\rconst char kBlockWidthStr[] = "-width";\rconst char kBlockOffsetStr[] = "-off";\rconst char kBlockCountStr[] = "-count";\rconst char kSuppressEndLinesStr[] = "-suppressEndLines";\r\rvoid toEOLNtext( FILE * input, FILE * output, char * buffer /* Must have room for kBufferPlay extra bytes per line. */,\r unsigned blocksize, unsigned width, unsigned offset, unsigned count,\r int suppressEndLines /*, int linecountflag */ )\r{\r unsigned long start = blocksize * offset;\r unsigned long bytecount = blocksize * count;\r unsigned long totalBytes = 0;\r unsigned screenHeight = blocksize / width;\r unsigned bufferWidth = width + kBufferPlay;\r\r/* dbg */ fprintf( stderr, "size: %u; width: %u; off: %u; count: %u\n", blocksize, width, offset, count ); \r\r if ( start > 0 )\r { fseek( input, start, SEEK_SET );\r }\r while ( !feof( input ) && ( totalBytes < bytecount ) )\r {\r int lineCount;\r for ( lineCount = 0; lineCount < screenHeight && !feof( input ); ++lineCount )\r {\r char * linestart = buffer + lineCount * bufferWidth;\r int length = fread( linestart, sizeof (char), width, input );\r totalBytes += length;\r while ( --length >= 0 \r && ( isspace( linestart[ length ] ) \r || !isprint( linestart[ length ] ) ) )\r /* "empty" loop */;\r linestart[ ++length ] = '\0';\r }\r if ( lineCount > 1 \r || ( lineCount == 1 && buffer[ 0 ] != '\0' ) )\r {\r int line = 0;\r if ( suppressEndLines )\r { while ( --lineCount > 0 && buffer[ lineCount * bufferWidth ] == '\0' ) \r { /* "empty" loop: note tested NUL is first character of line. */ }\r }\r else \r { --lineCount;\r }\r for ( line = 0; line <= lineCount; ++line ) /* End condition intentional! */\r { fputs( buffer + line * bufferWidth, output );\r fputc( '\n', output );\r }\r /* fputc( '\f', output ); This is not useful. */\r }\r }\r}\r\r\r#define FILE_START 0x200 /* beyond char range. */\r#define LINE_START 0x400 /* beyond char range. */\r\r\rvoid toScreens( FILE * input, FILE * output, char * buffer /* Must have room for kBufferPlay extra bytes per line. */,\r unsigned blocksize, unsigned width, unsigned offset, unsigned count\r /*, int linecountflag */ )\r{\r unsigned long start = blocksize * offset;\r unsigned screenHeight = ( blocksize / width );\r unsigned bufferWidth = width + kBufferPlay;\r int eolFlag = FILE_START;\r\r if ( start > 0 )\r { fseek( output, start, SEEK_SET );\r }\r while ( !feof( input ) )\r {\r int lineCount;\r for ( lineCount = 0; lineCount < screenHeight; ++lineCount )\r {\r int length = 0;\r char * line = buffer + lineCount * bufferWidth;\r int ch = LINE_START;\r while ( ( length < width ) && !feof( input ) )\r { ch = fgetc( input );\r if ( ( length == 0 )\r && ( ( ( ch == '\r' ) && ( eolFlag == '\n' ) )\r || ( ( ch == '\n' ) && ( eolFlag == '\r' ) ) )\r )\r { ch = fgetc( input );\r }\r eolFlag = ch;\r if ( ( ch == '\n' ) || ( ch == '\r' ) || feof( input ) )\r { break; /* The habit is to set a NUL, but not for SCREENs. */\r }\r line[ length++ ] = ch;\r/* dbg */ fputc( ch, stderr ); \r }\r/* dbg */ fprintf( stderr, "||end:%d:", length );\r while ( length < width )\r { line[ length++ ] = ' ';\r/* dbg */ fputc( '*', stderr );\r }\r/* dbg */ fprintf( stderr, "||:%d:%d\n", length, lineCount );\r }\r/* dbg */ fprintf( stderr, "<<screen:%d:>>\n", lineCount );\r if ( lineCount > 0 )\r { int line = 0;\r size_t count = 0;\r int error = 0;\r for ( line = 0; line < lineCount; ++line )\r { count = fwrite( buffer + line * bufferWidth, sizeof (char), width, output ); \r if ( ( count != width ) || ( ( error = ferror( output ) ) != 0 ) )\r { int i;\r fprintf( stderr, "Output error=%d; count: %lu::", error, count );\r for ( i = 0; i < width; ++i ) fputc( buffer[ line * bufferWidth + i ], stderr );\r fputc( '\n', stderr );\r }\r }\r }\r }\r}\r\r\rint getNumericParameter( const char parameter[], char * argstr,\r unsigned long * rval, long low, unsigned long high )\r{\r char * scanpt = argstr;\r unsigned long result = 0;\r size_t eqpt = strlen( parameter );\r if ( strncmp( parameter, argstr, eqpt ) == 0 ) \r {\r if ( argstr[ eqpt ] != '=' )\r { printf( "\t%s needs '=' in '%s', ", parameter, argstr );\r return INT_MIN | 16;\r }\r ++eqpt;\r scanpt += eqpt;\r result = strtoul( scanpt, &scanpt, 0 );\r if ( scanpt <= argstr + eqpt )\r { printf( "\tBad %s value specified in '%s'\n,", parameter, argstr );\r return INT_MIN | 32;\r }\r if ( ( result < low ) || ( result > high ) )\r { fprintf( stderr, "\t%s value %lu out of range in '%s', try %lu\n,", parameter, result, argstr, * rval );\r return INT_MIN | 64;\r }\r * rval = result;\r return 1;\r }\r return 0;\r}\r\r\rint main(int argc, char * argv[] )\r{\r FILE * input = stdin;\r FILE * output = stdout;\r char * buffer = NULL;\r int direction = 0;\r int errval = 0;\r unsigned long blocksize = kScreenSize;\r unsigned long width = kScreenWidth;\r unsigned long offset = 0;\r unsigned long count = UINT_MAX;\r unsigned long suppressEndLines = 0;\r int i;\r\r for ( i = 4; i < argc; ++i )\r { int berr = 0;\r int werr = 0;\r int oerr = 0;\r int cerr = 0;\r int serr = 0;\r if ( ( ( berr |= getNumericParameter( kBlockSizeStr, argv[ i ], &blocksize, 1, 0x8000UL ) ) > 0 )\r || ( ( werr |= getNumericParameter( kBlockWidthStr, argv[ i ], &width, 1, 1024 ) ) > 0 )\r || ( ( oerr |= getNumericParameter( kBlockOffsetStr, argv[ i ], &offset, 0, USHRT_MAX ) ) > 0 )\r || ( ( cerr |= getNumericParameter( kBlockCountStr, argv[ i ], &count, 1, USHRT_MAX ) ) > 0 ) \r || ( ( serr |= getNumericParameter( kSuppressEndLinesStr, argv[ i ], &suppressEndLines, 0, 1 ) ) > 0 ) \r )\r { /* empty */ }\r else\r { printf( "\tUnrecognized %s\n", argv[ i ] ); /* This isn't firing for gobbledygook. */\r }\r errval |= berr | werr | oerr | cerr | serr;\r }\r if ( ( blocksize % width ) != 0 )\r {\r errval |= INT_MIN | 1024;\r printf( "Block size %lu is not even multiple of edit width %lu.\n", blocksize, width );\r }\r if ( ( errval >= 0 ) && ( argc > 3 ) )\r {\r if ( strcmp( argv[ 1 ], kTo_ScreenStr ) == 0 )\r {\r direction = TO_SCREEN;\r }\r else if ( strcmp( argv[ 1 ], kTo_EOLN_textStr ) == 0 )\r {\r direction = TO_EOLN_TEXT;\r }\r if ( direction != 0 )\r {\r if ( strcmp( argv[ 2 ], "--" ) != 0 )\r {\r input = fopen( argv[ 2 ], "rb" );\r }\r if ( input == NULL )\r {\r fprintf( stderr, "Error opening file <%s> for input.\n", argv[ 2 ] );\r direction |= INT_MIN | 4;\r }\r if ( strcmp( argv[ 3 ], "--" ) != 0 )\r {\r output = fopen( argv[ 3 ], "r+b" );\r }\r if ( output == NULL )\r {\r fprintf( stderr, "Error opening file <%s> for output.\n", argv[ 3 ] );\r fclose( input );\r direction |= INT_MIN | 8;\r }\r if ( ( buffer = malloc( blocksize + kBufferPlay * ( blocksize / width ) ) ) == NULL )\r { fprintf( stderr, "Buffer allocation failure\n" );\r direction |= INT_MIN | 16;\r }\r }\r }\r if ( direction < -1 )\r {\r fprintf( stderr, "*** %s quitting. ***\n", argv[ 0 ] );\r return EXIT_FAILURE;\r }\r else if ( direction == 0 )\r {\r puts( "usage:" );\r printf( "\t%s %s <infile> <outfile> [ %s=<block-size> ] [ %s=<width> ] [ %s=<offset> ] [ %s=<count> ]\n", \r argv[ 0 ], kTo_ScreenStr, kBlockSizeStr, kBlockWidthStr, kBlockOffsetStr, kBlockCountStr );\r printf( "\t%s %s <infile> <outfile> [ %s=<block-size> ] [ %s=<width> ] [ %s=<offset> ] [ %s=<count> ] [ %s={0|1} ]\n", \r argv[ 0 ], kTo_EOLN_textStr, kBlockSizeStr, kBlockWidthStr, kBlockOffsetStr, kBlockCountStr, kSuppressEndLinesStr );\r printf( "** Default block size is %d, compatible with Forth SCREENs.\n", kScreenSize );\r printf( "** Default width is %d, compatible with Color Computer 1 & 2 text display.\n", kScreenWidth );\r printf( "** Default count is length of input file.\n" );\r printf( "** %s=1 to suppress trailing blank lines in SCREEN, default 0.\n", kSuppressEndLinesStr );\r printf( "** 0xhexadecimal and 0octal permitted for size, etc.\n" );\r printf( "** Replace <file> with -- for stdfiles in pipes\n" );\r /* printf( "\t%s --to-image <filename> <imagename> <offset>\n", argv[ 0 ] ); */\r return EXIT_SUCCESS;\r }\r\r switch ( direction )\r {\r case TO_SCREEN:\r toScreens( input, output, buffer, blocksize, width, offset, count );\r break;\r case TO_EOLN_TEXT:\r toEOLNtext( input, output, buffer, blocksize, width, offset, count, suppressEndLines );\r break;\r }\r if ( buffer != NULL )\r free( buffer );\r if ( output != stdout )\r fclose( output );\r if ( input != stdin )\r fclose( input );\r\r return EXIT_SUCCESS;\r}\r\r
\ No newline at end of file
+/* Tool for working with BIF-6809 images.\r// Written by Joel Matthew Rees, Amagasaki, Japan, April 2019,\r// Parts adapted from the author's 32col.c, written 1999.\r// Copyright 1999, 2019, Joel Matthew Rees.\r// Permission granted in advance for all uses\r// with the condition that this copyright and permission notice are retained.\r//\r// BIF-6809 project page: https://osdn.net/projects/bif-6809/\r*/\r\r#include <limits.h>\r#include <stdio.h>\r#include <stdlib.h> /* for EXIT_SUCCESS */\r#include <string.h>\r#include <ctype.h>\r\r\r#define kScreenSize 1024\r#define kScreenWidth 32\r#define kScreenHeight ( kScreenSize / kScreenWidth )\r#define kBufferPlay 3 /* room for CR/LF and NUL */\r#define kBufferWidth ( kScreenWidth + kBufferPlay ) /* Should never be used. */\r\r\r#define TO_SCREEN 1\rconst char kTo_ScreenStr[] = "--to-screens";\r#define TO_EOLN_TEXT 2\rconst char kTo_EOLN_textStr[] = "--to-eoln-text";\r\rconst char kBlockSizeStr[] = "-size";\rconst char kBlockWidthStr[] = "-width";\rconst char kBlockOffsetStr[] = "-off";\rconst char kBlockCountStr[] = "-count";\rconst char kSuppressEndLinesStr[] = "-suppressEndLines";\r\rvoid toEOLNtext( FILE * input, FILE * output, char * buffer /* Must have room for kBufferPlay extra bytes per line. */,\r unsigned blocksize, unsigned width, unsigned offset, unsigned count,\r int suppressEndLines /*, int linecountflag */ )\r{\r unsigned long start = blocksize * offset;\r unsigned long bytecount = blocksize * count;\r unsigned long totalBytes = 0;\r unsigned screenHeight = blocksize / width;\r unsigned bufferWidth = width + kBufferPlay;\r\r/* dbg */ fprintf( stderr, "size: %u; width: %u; off: %u; count: %u\n", blocksize, width, offset, count ); \r\r if ( start > 0 )\r { fseek( input, start, SEEK_SET );\r }\r while ( !feof( input ) && ( totalBytes < bytecount ) )\r {\r int lineCount;\r for ( lineCount = 0; lineCount < screenHeight && !feof( input ); ++lineCount )\r {\r char * linestart = buffer + lineCount * bufferWidth;\r int length = fread( linestart, sizeof (char), width, input );\r totalBytes += length;\r while ( --length >= 0 \r && ( isspace( linestart[ length ] ) \r || !isprint( linestart[ length ] ) ) )\r /* "empty" loop */;\r linestart[ ++length ] = '\0';\r }\r if ( lineCount > 1 \r || ( lineCount == 1 && buffer[ 0 ] != '\0' ) )\r {\r int line = 0;\r if ( suppressEndLines )\r { while ( --lineCount > 0 && buffer[ lineCount * bufferWidth ] == '\0' ) \r { /* "empty" loop: note tested NUL is first character of line. */ }\r }\r else \r { --lineCount;\r }\r for ( line = 0; line <= lineCount; ++line ) /* End condition intentional! */\r { fputs( buffer + line * bufferWidth, output );\r fputc( '\n', output );\r }\r /* fputc( '\f', output ); This is not useful. */\r }\r }\r}\r\r\r#define OVER_CHAR 0x100 /* char range boundary + 1 */\r#define FILE_START 0x200 /* beyond char range. */\r#define LINE_START 0x400 /* beyond char range. */\r#define LINE_START32 0x800 /* beyond char range. */\r\r\rvoid toScreens( FILE * input, FILE * output, char * buffer /* Must have room for kBufferPlay extra bytes per line. */,\r unsigned blocksize, unsigned width, unsigned offset, unsigned count\r /*, int linecountflag */ )\r{\r unsigned long start = blocksize * offset;\r unsigned screenHeight = ( blocksize / width );\r unsigned bufferWidth = width + kBufferPlay;\r int eolFlag = FILE_START;\r\r if ( start > 0 )\r { fseek( output, start, SEEK_SET );\r }\r while ( !feof( input ) )\r {\r int lineCount;\r for ( lineCount = 0; lineCount < screenHeight; ++lineCount )\r {\r int length = 0;\r char * line = buffer + lineCount * bufferWidth;\r int ch = LINE_START;\r while ( ( length < width ) && !feof( input ) )\r { ch = fgetc( input );\r if ( length == 0 )\r { if ( ( eolFlag < OVER_CHAR ) /* EOL did not come before 32nd. */\r && ( ( ch == '\n' ) || ( ch == '\r' ) ) )\r { eolFlag = ch; /* But throw ch away and get another. */\r ch = fgetc( input );\r }\r if ( ( ( ch == '\r' ) && ( eolFlag == '\n' ) )\r || ( ( ch == '\n' ) && ( eolFlag == '\r' ) ) )\r { /* Throw ch away and get another; eolFlag has done its job. */\r ch = fgetc( input );\r }\r }\r eolFlag = ch; /* At this point, ch is validly the first character of the line. */\r if ( ( ch == '\n' ) || ( ch == '\r' ) || feof( input ) )\r { eolFlag = LINE_START;\r break; /* The habit is to set a NUL, but not for SCREENs. */\r }\r line[ length++ ] = ch;\r/* dbg * / fputc( ch, stderr ); */\r }\r/* dbg * / fprintf( stderr, "||end:%d:", length ); */\r while ( length < width )\r { line[ length++ ] = ' ';\r/* dbg * / fputc( '*', stderr ); */\r }\r/* dbg * / fprintf( stderr, "||:%d:%d\n", length, lineCount ); */\r }\r/* dbg * / fprintf( stderr, "<<screen:%d:>>\n", lineCount ); */\r if ( lineCount > 0 )\r { int line = 0;\r size_t count = 0;\r int error = 0;\r for ( line = 0; line < lineCount; ++line )\r { count = fwrite( buffer + line * bufferWidth, sizeof (char), width, output ); \r if ( ( count != width ) || ( ( error = ferror( output ) ) != 0 ) )\r { fprintf( stderr, "Output error=%d; count: %lu::", error, count );\r }\r/* dbg * / fprintf( stderr, "Output error=%d; count: %lu::", ferror( output ), count ); */\r/* dbg * / { int i; for ( i = 0; i < width; ++i ) fputc( buffer[ line * bufferWidth + i ], stderr ); } */\r/* dbg * / fputc( '\n', stderr ); */\r }\r }\r }\r}\r\r\rint getNumericParameter( const char parameter[], char * argstr,\r unsigned long * rval, long low, unsigned long high )\r{\r char * scanpt = argstr;\r unsigned long result = 0;\r size_t eqpt = strlen( parameter );\r if ( strncmp( parameter, argstr, eqpt ) == 0 ) \r {\r if ( argstr[ eqpt ] != '=' )\r { printf( "\t%s needs '=' in '%s', ", parameter, argstr );\r return INT_MIN | 16;\r }\r ++eqpt;\r scanpt += eqpt;\r result = strtoul( scanpt, &scanpt, 0 );\r if ( scanpt <= argstr + eqpt )\r { printf( "\tBad %s value specified in '%s'\n,", parameter, argstr );\r return INT_MIN | 32;\r }\r if ( ( result < low ) || ( result > high ) )\r { fprintf( stderr, "\t%s value %lu out of range in '%s', try %lu\n,", parameter, result, argstr, * rval );\r return INT_MIN | 64;\r }\r * rval = result;\r return 1;\r }\r return 0;\r}\r\r\rint main(int argc, char * argv[] )\r{\r FILE * input = stdin;\r FILE * output = stdout;\r char * buffer = NULL;\r int direction = 0;\r int errval = 0;\r unsigned long blocksize = kScreenSize;\r unsigned long width = kScreenWidth;\r unsigned long offset = 0;\r unsigned long count = UINT_MAX;\r unsigned long suppressEndLines = 0;\r int i;\r\r for ( i = 4; i < argc; ++i )\r { int berr = 0;\r int werr = 0;\r int oerr = 0;\r int cerr = 0;\r int serr = 0;\r if ( ( ( berr |= getNumericParameter( kBlockSizeStr, argv[ i ], &blocksize, 1, 0x8000UL ) ) > 0 )\r || ( ( werr |= getNumericParameter( kBlockWidthStr, argv[ i ], &width, 1, 1024 ) ) > 0 )\r || ( ( oerr |= getNumericParameter( kBlockOffsetStr, argv[ i ], &offset, 0, USHRT_MAX ) ) > 0 )\r || ( ( cerr |= getNumericParameter( kBlockCountStr, argv[ i ], &count, 1, USHRT_MAX ) ) > 0 ) \r || ( ( serr |= getNumericParameter( kSuppressEndLinesStr, argv[ i ], &suppressEndLines, 0, 1 ) ) > 0 ) \r )\r { /* empty */ }\r else\r { printf( "\tUnrecognized %s\n", argv[ i ] ); /* This isn't firing for gobbledygook. */\r }\r errval |= berr | werr | oerr | cerr | serr;\r }\r if ( ( blocksize % width ) != 0 )\r {\r errval |= INT_MIN | 1024;\r printf( "Block size %lu is not even multiple of edit width %lu.\n", blocksize, width );\r }\r if ( ( errval >= 0 ) && ( argc > 3 ) )\r {\r if ( strcmp( argv[ 1 ], kTo_ScreenStr ) == 0 )\r {\r direction = TO_SCREEN;\r }\r else if ( strcmp( argv[ 1 ], kTo_EOLN_textStr ) == 0 )\r {\r direction = TO_EOLN_TEXT;\r }\r if ( direction != 0 )\r {\r if ( strcmp( argv[ 2 ], "--" ) != 0 )\r {\r input = fopen( argv[ 2 ], "rb" );\r }\r if ( input == NULL )\r {\r fprintf( stderr, "Error opening file <%s> for input.\n", argv[ 2 ] );\r direction |= INT_MIN | 4;\r }\r if ( strcmp( argv[ 3 ], "--" ) != 0 )\r {\r output = fopen( argv[ 3 ], "r+b" );\r }\r if ( output == NULL )\r {\r fprintf( stderr, "Error opening file <%s> for output.\n", argv[ 3 ] );\r fclose( input );\r direction |= INT_MIN | 8;\r }\r if ( ( buffer = malloc( blocksize + kBufferPlay * ( blocksize / width ) ) ) == NULL )\r { fprintf( stderr, "Buffer allocation failure\n" );\r direction |= INT_MIN | 16;\r }\r }\r }\r if ( direction < -1 )\r {\r fprintf( stderr, "*** %s quitting. ***\n", argv[ 0 ] );\r return EXIT_FAILURE;\r }\r else if ( direction == 0 )\r {\r puts( "usage:" );\r printf( "\t%s %s <infile> <outfile> [ %s=<block-size> ] [ %s=<width> ] [ %s=<offset> ] [ %s=<count> ]\n", \r argv[ 0 ], kTo_ScreenStr, kBlockSizeStr, kBlockWidthStr, kBlockOffsetStr, kBlockCountStr );\r printf( "\t%s %s <infile> <outfile> [ %s=<block-size> ] [ %s=<width> ] [ %s=<offset> ] [ %s=<count> ] [ %s={0|1} ]\n", \r argv[ 0 ], kTo_EOLN_textStr, kBlockSizeStr, kBlockWidthStr, kBlockOffsetStr, kBlockCountStr, kSuppressEndLinesStr );\r printf( "** Default block size is %d, compatible with Forth SCREENs.\n", kScreenSize );\r printf( "** Default width is %d, compatible with Color Computer 1 & 2 text display.\n", kScreenWidth );\r printf( "** Default count is length of input file.\n" );\r printf( "** %s=1 to suppress trailing blank lines in SCREEN, default 0.\n", kSuppressEndLinesStr );\r printf( "** 0xhexadecimal and 0octal permitted for size, etc.\n" );\r printf( "** Replace <file> with -- for stdfiles in pipes\n" );\r /* printf( "\t%s --to-image <filename> <imagename> <offset>\n", argv[ 0 ] ); */\r return EXIT_SUCCESS;\r }\r\r switch ( direction )\r {\r case TO_SCREEN:\r toScreens( input, output, buffer, blocksize, width, offset, count );\r break;\r case TO_EOLN_TEXT:\r toEOLNtext( input, output, buffer, blocksize, width, offset, count, suppressEndLines );\r break;\r }\r if ( buffer != NULL )\r free( buffer );\r if ( output != stdout )\r fclose( output );\r if ( input != stdin )\r fclose( input );\r\r return EXIT_SUCCESS;\r}\r\r
\ No newline at end of file
-( Archetypical implementation )
-( of the sieve of eratosthenes )
-( in FORTH -- fig, bif-c -- )
-( using more )
-( of the FORTH idiom. )
-( Copyright 2015, 2019,
-( Joel Matthew Rees )
-( By Joel Matthew Rees, )
-( Amagasaki, Japan, 2015 )
-( All rights reserved. )
-( Permission granted by the )
-( author to use this code )
-( for any purpose, )
-( on condition that )
-( substantial use )
-( shall retain this copyright )
-( and permission notice. )
-
-
-
-VOCABULARY sieve-local
-( Make a local symbol table. )
-sieve-local DEFINITIONS
-( Switch to the )
-( local vocabulary. )
+( ARCHETYPICAL IMPLEMENTATION )
+( OF THE SIEVE OF ERATOSTHENES )
+( IN FORTH -- BIF, FIG -- )
+( USING A LITTLE MORE )
+( OF THE FORTH AND BIF IDIOMS. )
+( COPYRIGHT 2015, 2019,
+( JOEL MATTHEW REES )
+( BY JOEL MATTHEW REES, )
+( AMAGASAKI, JAPAN, 2015 )
+( ALL RIGHTS RESERVED. )
+( PERMISSION GRANTED BY THE )
+( AUTHOR TO USE THIS CODE )
+( FOR ANY PURPOSE, )
+( ON CONDITION THAT )
+( SUBSTANTIAL USE )
+( SHALL RETAIN THIS COPYRIGHT )
+( AND PERMISSION NOTICE. )
+
+( PERL-ESQUE, TOO. )
+
+VOCABULARY SIEVE-LOCAL
+( MAKE A LOCAL SYMBOL TABLE. )
+SIEVE-LOCAL DEFINITIONS
+( SWITCH TO THE )
+( LOCAL VOCABULARY. )
256 CONSTANT MAXSIEVE
5 CONSTANT DISPWIDTH
-( enough digits )
-( to display MAXSIEVE )
+( ENOUGH DIGITS )
+( TO DISPLAY MAXSIEVE )
-0 VARIABLE sieve
-( Old FORTHs don't provide a )
-( default behavior for CREATE )
-( gforth will leave )
-( the zero there. )
-( Old FORTHs need )
-( an initial value. )
-
- HERE sieve - DUP
-( Old FORTHs don't provide )
-( a CELL width. )
- MAXSIEVE SWAP - ALLOT
-( Allocate the rest )
-( of the byte array. )
+0 VARIABLE SIEVE
+( OLD FORTHS DON'T PROVIDE A )
+( DEFAULT BEHAVIOR FOR CREATE )
+( GFORTH WILL LEAVE )
+( THE ZERO THERE. )
+( OLD FORTHS NEED )
+( AN INITIAL VALUE. )
+ HERE SIEVE -
+( OLD FORTHS DON'T PROVIDE )
+( A CELL WIDTH. )
CONSTANT CELLWIDTH
-( To show how it can be done. )
-
- -->
-
-
-
-
-
-
-
-
-: sieveInit ( -- adr )
-0 sieve C!
-( 0 is not prime. )
-0 sieve 1+ C!
-( 1 is not prime. )
-sieve MAXSIEVE 2 DO
-( set flags to true )
-( for 2 to FINALPASS. )
- -1 OVER I + C! LOOP
-( sieve pointer -- )
-( still on stack. )
-;
-
- -->
-
-
-
-
-
-
-
-
-
-
-
+( TO SHOW HOW IT CAN BE DONE. )
+CELLWIDTH MAXSIEVE SWAP - ALLOT
+( ALLOCATE THE REST )
+( OF THE BYTE ARRAY. )
+: NOT-PRIME! ( ADR N -- )
++ 0 SWAP ! ;
+: IS-PRIME? ( ADR N -- F )
++ @ ;
+ -->
+: SIEVE-INIT ( ADR -- )
+0 OVER C!
+( 0 IS NOT PRIME. )
+0 OVER 1+ C!
+( 1 IS NOT PRIME. )
+( SET FLAGS TO TRUE )
+( FOR 2 TO FINALPASS. )
+2+ MAXSIEVE 2- -1 FILL
+ ;
-: primePass ( adr prime -- adr )
+: PRIME-PASS ( ADR PRIME -- )
+( DOUBLE IS FIRST MULTIPLE )
MAXSIEVE OVER DUP + DO
-( start at first multiple )
-( -- double. )
- OVER I + 0 SWAP C!
-( clear at this multiple. )
- DUP +LOOP
-( next multiple )
+ OVER I NOT-PRIME!
+ DUP +LOOP ( NEXT MULTIPLE )
DROP ;
-( sieve address still )
-( on stack. )
-: findPrimes ( adr -- adr )
+: FIND-PRIMES ( ADR -- )
FINALPASS 2 DO
-( clear flags )
-( at all multiples. )
- DUP I + C@ IF
-( don't bother if not prime. )
- I primePass
+ DUP I IS-PRIME? IF
+ I PRIME-PASS
ENDIF
LOOP ;
-( sieve still on stack. )
-
-->
+: COUNT-PRIMES ( ADR -- )
+." COUNT: " .
+0 SWAP
+MAXSIEVE 0 DO
+ DUP I IS-PRIME? IF
+ SWAP 1+ SWAP
+ ENDIF
+LOOP DROP CR
+ ;
+: PRINT-ALL ( ADR -- )
+MAXSIEVE 0 DO
+ I DISPWIDTH .R ." : IS "
+ DUP I IS-PRIME? 0= IF
+ ." NOT "
+ ENDIF
+ ." PRIME." CR
+LOOP
+DROP ;
-
-: printPrimes ( adr -- )
+: PRINT-PRIMES ( ADR -- )
MAXSIEVE 0 DO
- I DISPWIDTH .R ." : is "
- DUP I + C@ 0= IF
- ." not "
- ENDIF
- ." prime." CR
-LOOP DROP ;
+ DUP I IS-PRIME?
+ IF . ENDIF
+LOOP
+DROP CR ;
+-->
+
+
-FORTH DEFINITIONS
+BIF DEFINITIONS
-: sieveMain ( -- )
-[ sieve-local ] sieveInit
-findPrimes
-printPrimes ;
+: SIEVEMAIN ( -- )
+[ SIEVE-LOCAL ]
+SIEVE SIEVE-INIT
+SIEVE FIND-PRIMES
+SIEVE PRINT-PRIMES
+SIEVE COUNT-PRIMES ;
-sieveMain
+SIEVEMAIN
-( Archetypical implementation )
-( of the sieve of eratosthenes )
-( in FORTH -- BIF-6809 -- )
-( Copyright 2015, 2019, )
-( Joel Matthew Rees )
-( Written by Joel Mathew Rees, )
-( Amagasaki, Japan, 2015, 2019 )
-( All rights reserved. )
-( Permission granted by the )
-( author to use this code )
-( for any purpose, )
-( on condition that )
-( substantial use )
-( shall retain this copyright )
-( and permission notice. )
+( ARCHETYPICAL IMPLEMENTATION )
+( OF THE SIEVE OF ERATOSTHENES )
+( IN FORTH -- BIF-6809 -- )
+( COPYRIGHT 2015, 2019, )
+( JOEL MATTHEW REES )
+( WRITTEN BY JOEL MATHEW REES, )
+( AMAGASAKI, JAPAN, 2015, 2019 )
+( ALL RIGHTS RESERVED. )
+( PERMISSION GRANTED BY THE )
+( AUTHOR TO USE THIS CODE )
+( FOR ANY PURPOSE, )
+( ON CONDITION THAT )
+( SUBSTANTIAL USE )
+( SHALL RETAIN THIS COPYRIGHT )
+( AND PERMISSION NOTICE. )
-256 constant MAXSIEVE
+256 CONSTANT MAXSIEVE
MAXSIEVE 1- 2 /
- constant FINALPASS
+ CONSTANT FINALPASS
-5 constant DISPWIDTH
-( enough digits )
-( to display MAXSIEVE )
+5 CONSTANT DISPWIDTH
+( ENOUGH DIGITS )
+( TO DISPLAY MAXSIEVE )
-create sieve MAXSIEVE allot
+CREATE SIEVE MAXSIEVE ALLOT
-->
-: sieveMain ( -- )
-0 sieve c!
-( 0 is not prime. )
-0 sieve 1+ c!
-( 1 is not prime. )
-sieve MAXSIEVE 2 do
-( set flags to true )
-( for 2 to FINALPASS. )
- -1 over i + c! loop
-( sieve ptr still on stack. )
-FINALPASS 2 do
-( clear flags at multiples. )
- dup i + c@ if
-( don't bother if not prime. )
- MAXSIEVE i dup + ?do
-( start at first multiple )
-( -- double. )
- 0 over i + c!
-( clear at this multiple. )
- j +loop
-( sieve still on stack. )
- then
-loop ( sieve still on stack. )
-MAXSIEVE 0 do
- i DISPWIDTH .r ." : is "
- dup i + c@ 0= if
- ." not "
- then
- ." prime." cr
-loop drop ;
+
+: SIEVEMAIN ( -- )
+0 SIEVE C!
+( 0 IS NOT PRIME. )
+0 SIEVE 1+ C!
+( 1 IS NOT PRIME. )
+SIEVE MAXSIEVE 2 DO
+( SET FLAGS TO TRUE )
+( FOR 2 TO FINALPASS. )
+ -1 OVER I + C! LOOP
+( SIEVE PTR STILL ON STACK. )
+FINALPASS 2 DO
+( CLEAR FLAGS AT MULTIPLES. )
+ DUP I + C@ IF
+( DON'T BOTHER IF NOT PRIME. )
+ MAXSIEVE I DUP + ?DO
+( START AT FIRST MULTIPLE )
+( -- DOUBLE. )
+ 0 OVER I + C!
+( CLEAR AT THIS MULTIPLE. )
+ J +LOOP
+( SIEVE STILL ON STACK. )
+ THEN
+LOOP ( SIEVE STILL ON STACK. )
+MAXSIEVE 0 DO
+ I DISPWIDTH .R ." : IS "
+ DUP I + C@ 0= IF
+ ." NOT "
+ THEN
+ ." PRIME." CR
+LOOP DROP ;
-->
-sieveMain
+SIEVEMAIN