| Revision | f2ca6c0eaf45226c1fda1b41a264196bd643729a (tree) |
|---|---|
| Zeit | 2019-05-02 17:55:30 |
| Autor |  Joel Matthew Rees <joel.rees@gmai...> |
| Commiter | Joel Matthew Rees |
still trying to make the sieve stuff work.
rs_sieve_bif.fs at least works.
Using the image sieveplay.dsk.
bif-img.c (diff)
commands.txt (diff)
testsource/rs_sieve_bif.fs (diff) testsource/sievefig.bif6809 (diff) testsource/sievegforth.bif6809 (diff)| @@ -1 +1 @@ | ||
| 1 | -/* Tool for working with BIF-6809 images. // Written by Joel Matthew Rees, Amagasaki, Japan, April 2019, // Parts adapted from the author's 32col.c, written 1999. // Copyright 1999, 2019, Joel Matthew Rees. // Permission granted in advance for all uses // with the condition that this copyright and permission notice are retained. // // BIF-6809 project page: https://osdn.net/projects/bif-6809/ */ #include <limits.h> #include <stdio.h> #include <stdlib.h> /* for EXIT_SUCCESS */ #include <string.h> #include <ctype.h> #define kScreenSize 1024 #define kScreenWidth 32 #define kScreenHeight ( kScreenSize / kScreenWidth ) #define kBufferPlay 3 /* room for CR/LF and NUL */ #define kBufferWidth ( kScreenWidth + kBufferPlay ) /* Should never be used. */ #define TO_SCREEN 1 const char kTo_ScreenStr[] = "--to-screens"; #define TO_EOLN_TEXT 2 const char kTo_EOLN_textStr[] = "--to-eoln-text"; const char kBlockSizeStr[] = "-size"; const char kBlockWidthStr[] = "-width"; const char kBlockOffsetStr[] = "-off"; const char kBlockCountStr[] = "-count"; const char kSuppressEndLinesStr[] = "-suppressEndLines"; void toEOLNtext( FILE * input, FILE * output, char * buffer /* Must have room for kBufferPlay extra bytes per line. */, unsigned blocksize, unsigned width, unsigned offset, unsigned count, int suppressEndLines /*, int linecountflag */ ) { unsigned long start = blocksize * offset; unsigned long bytecount = blocksize * count; unsigned long totalBytes = 0; unsigned screenHeight = blocksize / width; unsigned bufferWidth = width + kBufferPlay; /* dbg */ fprintf( stderr, "size: %u; width: %u; off: %u; count: %u\n", blocksize, width, offset, count ); if ( start > 0 ) { fseek( input, start, SEEK_SET ); } while ( !feof( input ) && ( totalBytes < bytecount ) ) { int lineCount; for ( lineCount = 0; lineCount < screenHeight && !feof( input ); ++lineCount ) { char * linestart = buffer + lineCount * bufferWidth; int length = fread( linestart, sizeof (char), width, input ); totalBytes += length; while ( --length >= 0 && ( isspace( linestart[ length ] ) || !isprint( linestart[ length ] ) ) ) /* "empty" loop */; linestart[ ++length ] = '\0'; } if ( lineCount > 1 || ( lineCount == 1 && buffer[ 0 ] != '\0' ) ) { int line = 0; if ( suppressEndLines ) { while ( --lineCount > 0 && buffer[ lineCount * bufferWidth ] == '\0' ) { /* "empty" loop: note tested NUL is first character of line. */ } } else { --lineCount; } for ( line = 0; line <= lineCount; ++line ) /* End condition intentional! */ { fputs( buffer + line * bufferWidth, output ); fputc( '\n', output ); } /* fputc( '\f', output ); This is not useful. */ } } } #define FILE_START 0x200 /* beyond char range. */ #define LINE_START 0x400 /* beyond char range. */ void toScreens( FILE * input, FILE * output, char * buffer /* Must have room for kBufferPlay extra bytes per line. */, unsigned blocksize, unsigned width, unsigned offset, unsigned count /*, int linecountflag */ ) { unsigned long start = blocksize * offset; unsigned screenHeight = ( blocksize / width ); unsigned bufferWidth = width + kBufferPlay; int eolFlag = FILE_START; if ( start > 0 ) { fseek( output, start, SEEK_SET ); } while ( !feof( input ) ) { int lineCount; for ( lineCount = 0; lineCount < screenHeight; ++lineCount ) { int length = 0; char * line = buffer + lineCount * bufferWidth; int ch = LINE_START; while ( ( length < width ) && !feof( input ) ) { ch = fgetc( input ); if ( ( length == 0 ) && ( ( ( ch == '\r' ) && ( eolFlag == '\n' ) ) || ( ( ch == '\n' ) && ( eolFlag == '\r' ) ) ) ) { ch = fgetc( input ); } eolFlag = ch; if ( ( ch == '\n' ) || ( ch == '\r' ) || feof( input ) ) { break; /* The habit is to set a NUL, but not for SCREENs. */ } line[ length++ ] = ch; /* dbg */ fputc( ch, stderr ); } /* dbg */ fprintf( stderr, "||end:%d:", length ); while ( length < width ) { line[ length++ ] = ' '; /* dbg */ fputc( '*', stderr ); } /* dbg */ fprintf( stderr, "||:%d:%d\n", length, lineCount ); } /* dbg */ fprintf( stderr, "<<screen:%d:>>\n", lineCount ); if ( lineCount > 0 ) { int line = 0; size_t count = 0; int error = 0; for ( line = 0; line < lineCount; ++line ) { count = fwrite( buffer + line * bufferWidth, sizeof (char), width, output ); if ( ( count != width ) || ( ( error = ferror( output ) ) != 0 ) ) { int i; fprintf( stderr, "Output error=%d; count: %lu::", error, count ); for ( i = 0; i < width; ++i ) fputc( buffer[ line * bufferWidth + i ], stderr ); fputc( '\n', stderr ); } } } } } int getNumericParameter( const char parameter[], char * argstr, unsigned long * rval, long low, unsigned long high ) { char * scanpt = argstr; unsigned long result = 0; size_t eqpt = strlen( parameter ); if ( strncmp( parameter, argstr, eqpt ) == 0 ) { if ( argstr[ eqpt ] != '=' ) { printf( "\t%s needs '=' in '%s', ", parameter, argstr ); return INT_MIN | 16; } ++eqpt; scanpt += eqpt; result = strtoul( scanpt, &scanpt, 0 ); if ( scanpt <= argstr + eqpt ) { printf( "\tBad %s value specified in '%s'\n,", parameter, argstr ); return INT_MIN | 32; } if ( ( result < low ) || ( result > high ) ) { fprintf( stderr, "\t%s value %lu out of range in '%s', try %lu\n,", parameter, result, argstr, * rval ); return INT_MIN | 64; } * rval = result; return 1; } return 0; } int main(int argc, char * argv[] ) { FILE * input = stdin; FILE * output = stdout; char * buffer = NULL; int direction = 0; int errval = 0; unsigned long blocksize = kScreenSize; unsigned long width = kScreenWidth; unsigned long offset = 0; unsigned long count = UINT_MAX; unsigned long suppressEndLines = 0; int i; for ( i = 4; i < argc; ++i ) { int berr = 0; int werr = 0; int oerr = 0; int cerr = 0; int serr = 0; if ( ( ( berr |= getNumericParameter( kBlockSizeStr, argv[ i ], &blocksize, 1, 0x8000UL ) ) > 0 ) || ( ( werr |= getNumericParameter( kBlockWidthStr, argv[ i ], &width, 1, 1024 ) ) > 0 ) || ( ( oerr |= getNumericParameter( kBlockOffsetStr, argv[ i ], &offset, 0, USHRT_MAX ) ) > 0 ) || ( ( cerr |= getNumericParameter( kBlockCountStr, argv[ i ], &count, 1, USHRT_MAX ) ) > 0 ) || ( ( serr |= getNumericParameter( kSuppressEndLinesStr, argv[ i ], &suppressEndLines, 0, 1 ) ) > 0 ) ) { /* empty */ } else { printf( "\tUnrecognized %s\n", argv[ i ] ); /* This isn't firing for gobbledygook. */ } errval |= berr | werr | oerr | cerr | serr; } if ( ( blocksize % width ) != 0 ) { errval |= INT_MIN | 1024; printf( "Block size %lu is not even multiple of edit width %lu.\n", blocksize, width ); } if ( ( errval >= 0 ) && ( argc > 3 ) ) { if ( strcmp( argv[ 1 ], kTo_ScreenStr ) == 0 ) { direction = TO_SCREEN; } else if ( strcmp( argv[ 1 ], kTo_EOLN_textStr ) == 0 ) { direction = TO_EOLN_TEXT; } if ( direction != 0 ) { if ( strcmp( argv[ 2 ], "--" ) != 0 ) { input = fopen( argv[ 2 ], "rb" ); } if ( input == NULL ) { fprintf( stderr, "Error opening file <%s> for input.\n", argv[ 2 ] ); direction |= INT_MIN | 4; } if ( strcmp( argv[ 3 ], "--" ) != 0 ) { output = fopen( argv[ 3 ], "r+b" ); } if ( output == NULL ) { fprintf( stderr, "Error opening file <%s> for output.\n", argv[ 3 ] ); fclose( input ); direction |= INT_MIN | 8; } if ( ( buffer = malloc( blocksize + kBufferPlay * ( blocksize / width ) ) ) == NULL ) { fprintf( stderr, "Buffer allocation failure\n" ); direction |= INT_MIN | 16; } } } if ( direction < -1 ) { fprintf( stderr, "*** %s quitting. ***\n", argv[ 0 ] ); return EXIT_FAILURE; } else if ( direction == 0 ) { puts( "usage:" ); printf( "\t%s %s <infile> <outfile> [ %s=<block-size> ] [ %s=<width> ] [ %s=<offset> ] [ %s=<count> ]\n", argv[ 0 ], kTo_ScreenStr, kBlockSizeStr, kBlockWidthStr, kBlockOffsetStr, kBlockCountStr ); printf( "\t%s %s <infile> <outfile> [ %s=<block-size> ] [ %s=<width> ] [ %s=<offset> ] [ %s=<count> ] [ %s={0|1} ]\n", argv[ 0 ], kTo_EOLN_textStr, kBlockSizeStr, kBlockWidthStr, kBlockOffsetStr, kBlockCountStr, kSuppressEndLinesStr ); printf( "** Default block size is %d, compatible with Forth SCREENs.\n", kScreenSize ); printf( "** Default width is %d, compatible with Color Computer 1 & 2 text display.\n", kScreenWidth ); printf( "** Default count is length of input file.\n" ); printf( "** %s=1 to suppress trailing blank lines in SCREEN, default 0.\n", kSuppressEndLinesStr ); printf( "** 0xhexadecimal and 0octal permitted for size, etc.\n" ); printf( "** Replace <file> with -- for stdfiles in pipes\n" ); /* printf( "\t%s --to-image <filename> <imagename> <offset>\n", argv[ 0 ] ); */ return EXIT_SUCCESS; } switch ( direction ) { case TO_SCREEN: toScreens( input, output, buffer, blocksize, width, offset, count ); break; case TO_EOLN_TEXT: toEOLNtext( input, output, buffer, blocksize, width, offset, count, suppressEndLines ); break; } if ( buffer != NULL ) free( buffer ); if ( output != stdout ) fclose( output ); if ( input != stdin ) fclose( input ); return EXIT_SUCCESS; } | |
| \ No newline at end of file | ||
| 1 | +/* Tool for working with BIF-6809 images. // Written by Joel Matthew Rees, Amagasaki, Japan, April 2019, // Parts adapted from the author's 32col.c, written 1999. // Copyright 1999, 2019, Joel Matthew Rees. // Permission granted in advance for all uses // with the condition that this copyright and permission notice are retained. // // BIF-6809 project page: https://osdn.net/projects/bif-6809/ */ #include <limits.h> #include <stdio.h> #include <stdlib.h> /* for EXIT_SUCCESS */ #include <string.h> #include <ctype.h> #define kScreenSize 1024 #define kScreenWidth 32 #define kScreenHeight ( kScreenSize / kScreenWidth ) #define kBufferPlay 3 /* room for CR/LF and NUL */ #define kBufferWidth ( kScreenWidth + kBufferPlay ) /* Should never be used. */ #define TO_SCREEN 1 const char kTo_ScreenStr[] = "--to-screens"; #define TO_EOLN_TEXT 2 const char kTo_EOLN_textStr[] = "--to-eoln-text"; const char kBlockSizeStr[] = "-size"; const char kBlockWidthStr[] = "-width"; const char kBlockOffsetStr[] = "-off"; const char kBlockCountStr[] = "-count"; const char kSuppressEndLinesStr[] = "-suppressEndLines"; void toEOLNtext( FILE * input, FILE * output, char * buffer /* Must have room for kBufferPlay extra bytes per line. */, unsigned blocksize, unsigned width, unsigned offset, unsigned count, int suppressEndLines /*, int linecountflag */ ) { unsigned long start = blocksize * offset; unsigned long bytecount = blocksize * count; unsigned long totalBytes = 0; unsigned screenHeight = blocksize / width; unsigned bufferWidth = width + kBufferPlay; /* dbg */ fprintf( stderr, "size: %u; width: %u; off: %u; count: %u\n", blocksize, width, offset, count ); if ( start > 0 ) { fseek( input, start, SEEK_SET ); } while ( !feof( input ) && ( totalBytes < bytecount ) ) { int lineCount; for ( lineCount = 0; lineCount < screenHeight && !feof( input ); ++lineCount ) { char * linestart = buffer + lineCount * bufferWidth; int length = fread( linestart, sizeof (char), width, input ); totalBytes += length; while ( --length >= 0 && ( isspace( linestart[ length ] ) || !isprint( linestart[ length ] ) ) ) /* "empty" loop */; linestart[ ++length ] = '\0'; } if ( lineCount > 1 || ( lineCount == 1 && buffer[ 0 ] != '\0' ) ) { int line = 0; if ( suppressEndLines ) { while ( --lineCount > 0 && buffer[ lineCount * bufferWidth ] == '\0' ) { /* "empty" loop: note tested NUL is first character of line. */ } } else { --lineCount; } for ( line = 0; line <= lineCount; ++line ) /* End condition intentional! */ { fputs( buffer + line * bufferWidth, output ); fputc( '\n', output ); } /* fputc( '\f', output ); This is not useful. */ } } } #define OVER_CHAR 0x100 /* char range boundary + 1 */ #define FILE_START 0x200 /* beyond char range. */ #define LINE_START 0x400 /* beyond char range. */ #define LINE_START32 0x800 /* beyond char range. */ void toScreens( FILE * input, FILE * output, char * buffer /* Must have room for kBufferPlay extra bytes per line. */, unsigned blocksize, unsigned width, unsigned offset, unsigned count /*, int linecountflag */ ) { unsigned long start = blocksize * offset; unsigned screenHeight = ( blocksize / width ); unsigned bufferWidth = width + kBufferPlay; int eolFlag = FILE_START; if ( start > 0 ) { fseek( output, start, SEEK_SET ); } while ( !feof( input ) ) { int lineCount; for ( lineCount = 0; lineCount < screenHeight; ++lineCount ) { int length = 0; char * line = buffer + lineCount * bufferWidth; int ch = LINE_START; while ( ( length < width ) && !feof( input ) ) { ch = fgetc( input ); if ( length == 0 ) { if ( ( eolFlag < OVER_CHAR ) /* EOL did not come before 32nd. */ && ( ( ch == '\n' ) || ( ch == '\r' ) ) ) { eolFlag = ch; /* But throw ch away and get another. */ ch = fgetc( input ); } if ( ( ( ch == '\r' ) && ( eolFlag == '\n' ) ) || ( ( ch == '\n' ) && ( eolFlag == '\r' ) ) ) { /* Throw ch away and get another; eolFlag has done its job. */ ch = fgetc( input ); } } eolFlag = ch; /* At this point, ch is validly the first character of the line. */ if ( ( ch == '\n' ) || ( ch == '\r' ) || feof( input ) ) { eolFlag = LINE_START; break; /* The habit is to set a NUL, but not for SCREENs. */ } line[ length++ ] = ch; /* dbg * / fputc( ch, stderr ); */ } /* dbg * / fprintf( stderr, "||end:%d:", length ); */ while ( length < width ) { line[ length++ ] = ' '; /* dbg * / fputc( '*', stderr ); */ } /* dbg * / fprintf( stderr, "||:%d:%d\n", length, lineCount ); */ } /* dbg * / fprintf( stderr, "<<screen:%d:>>\n", lineCount ); */ if ( lineCount > 0 ) { int line = 0; size_t count = 0; int error = 0; for ( line = 0; line < lineCount; ++line ) { count = fwrite( buffer + line * bufferWidth, sizeof (char), width, output ); if ( ( count != width ) || ( ( error = ferror( output ) ) != 0 ) ) { fprintf( stderr, "Output error=%d; count: %lu::", error, count ); } /* dbg * / fprintf( stderr, "Output error=%d; count: %lu::", ferror( output ), count ); */ /* dbg * / { int i; for ( i = 0; i < width; ++i ) fputc( buffer[ line * bufferWidth + i ], stderr ); } */ /* dbg * / fputc( '\n', stderr ); */ } } } } int getNumericParameter( const char parameter[], char * argstr, unsigned long * rval, long low, unsigned long high ) { char * scanpt = argstr; unsigned long result = 0; size_t eqpt = strlen( parameter ); if ( strncmp( parameter, argstr, eqpt ) == 0 ) { if ( argstr[ eqpt ] != '=' ) { printf( "\t%s needs '=' in '%s', ", parameter, argstr ); return INT_MIN | 16; } ++eqpt; scanpt += eqpt; result = strtoul( scanpt, &scanpt, 0 ); if ( scanpt <= argstr + eqpt ) { printf( "\tBad %s value specified in '%s'\n,", parameter, argstr ); return INT_MIN | 32; } if ( ( result < low ) || ( result > high ) ) { fprintf( stderr, "\t%s value %lu out of range in '%s', try %lu\n,", parameter, result, argstr, * rval ); return INT_MIN | 64; } * rval = result; return 1; } return 0; } int main(int argc, char * argv[] ) { FILE * input = stdin; FILE * output = stdout; char * buffer = NULL; int direction = 0; int errval = 0; unsigned long blocksize = kScreenSize; unsigned long width = kScreenWidth; unsigned long offset = 0; unsigned long count = UINT_MAX; unsigned long suppressEndLines = 0; int i; for ( i = 4; i < argc; ++i ) { int berr = 0; int werr = 0; int oerr = 0; int cerr = 0; int serr = 0; if ( ( ( berr |= getNumericParameter( kBlockSizeStr, argv[ i ], &blocksize, 1, 0x8000UL ) ) > 0 ) || ( ( werr |= getNumericParameter( kBlockWidthStr, argv[ i ], &width, 1, 1024 ) ) > 0 ) || ( ( oerr |= getNumericParameter( kBlockOffsetStr, argv[ i ], &offset, 0, USHRT_MAX ) ) > 0 ) || ( ( cerr |= getNumericParameter( kBlockCountStr, argv[ i ], &count, 1, USHRT_MAX ) ) > 0 ) || ( ( serr |= getNumericParameter( kSuppressEndLinesStr, argv[ i ], &suppressEndLines, 0, 1 ) ) > 0 ) ) { /* empty */ } else { printf( "\tUnrecognized %s\n", argv[ i ] ); /* This isn't firing for gobbledygook. */ } errval |= berr | werr | oerr | cerr | serr; } if ( ( blocksize % width ) != 0 ) { errval |= INT_MIN | 1024; printf( "Block size %lu is not even multiple of edit width %lu.\n", blocksize, width ); } if ( ( errval >= 0 ) && ( argc > 3 ) ) { if ( strcmp( argv[ 1 ], kTo_ScreenStr ) == 0 ) { direction = TO_SCREEN; } else if ( strcmp( argv[ 1 ], kTo_EOLN_textStr ) == 0 ) { direction = TO_EOLN_TEXT; } if ( direction != 0 ) { if ( strcmp( argv[ 2 ], "--" ) != 0 ) { input = fopen( argv[ 2 ], "rb" ); } if ( input == NULL ) { fprintf( stderr, "Error opening file <%s> for input.\n", argv[ 2 ] ); direction |= INT_MIN | 4; } if ( strcmp( argv[ 3 ], "--" ) != 0 ) { output = fopen( argv[ 3 ], "r+b" ); } if ( output == NULL ) { fprintf( stderr, "Error opening file <%s> for output.\n", argv[ 3 ] ); fclose( input ); direction |= INT_MIN | 8; } if ( ( buffer = malloc( blocksize + kBufferPlay * ( blocksize / width ) ) ) == NULL ) { fprintf( stderr, "Buffer allocation failure\n" ); direction |= INT_MIN | 16; } } } if ( direction < -1 ) { fprintf( stderr, "*** %s quitting. ***\n", argv[ 0 ] ); return EXIT_FAILURE; } else if ( direction == 0 ) { puts( "usage:" ); printf( "\t%s %s <infile> <outfile> [ %s=<block-size> ] [ %s=<width> ] [ %s=<offset> ] [ %s=<count> ]\n", argv[ 0 ], kTo_ScreenStr, kBlockSizeStr, kBlockWidthStr, kBlockOffsetStr, kBlockCountStr ); printf( "\t%s %s <infile> <outfile> [ %s=<block-size> ] [ %s=<width> ] [ %s=<offset> ] [ %s=<count> ] [ %s={0|1} ]\n", argv[ 0 ], kTo_EOLN_textStr, kBlockSizeStr, kBlockWidthStr, kBlockOffsetStr, kBlockCountStr, kSuppressEndLinesStr ); printf( "** Default block size is %d, compatible with Forth SCREENs.\n", kScreenSize ); printf( "** Default width is %d, compatible with Color Computer 1 & 2 text display.\n", kScreenWidth ); printf( "** Default count is length of input file.\n" ); printf( "** %s=1 to suppress trailing blank lines in SCREEN, default 0.\n", kSuppressEndLinesStr ); printf( "** 0xhexadecimal and 0octal permitted for size, etc.\n" ); printf( "** Replace <file> with -- for stdfiles in pipes\n" ); /* printf( "\t%s --to-image <filename> <imagename> <offset>\n", argv[ 0 ] ); */ return EXIT_SUCCESS; } switch ( direction ) { case TO_SCREEN: toScreens( input, output, buffer, blocksize, width, offset, count ); break; case TO_EOLN_TEXT: toEOLNtext( input, output, buffer, blocksize, width, offset, count, suppressEndLines ); break; } if ( buffer != NULL ) free( buffer ); if ( output != stdout ) fclose( output ); if ( input != stdin ) fclose( input ); return EXIT_SUCCESS; } | |
| \ No newline at end of file |
| @@ -45,3 +45,16 @@ imgtool get coco_jvc_rsdos ../../foreign6809/play/play.dsk PRIMES.BAS --filter=a | ||
| 45 | 45 | |
| 46 | 46 | dd if=/dev/zero of=blank.dsk bs=256 count=630 |
| 47 | 47 | |
| 48 | +# Compiling bif-img: | |
| 49 | +cc -Wall -o bif-img bif-img.c | |
| 50 | + | |
| 51 | +# Inserting variable line source in sievegforth.bif6809 | |
| 52 | +# into disk image sieveplay.dsk at SCREEN 50: | |
| 53 | +../bif-img --to-screens sievegforth.bif6809 sieveplay.dsk -off=50 | |
| 54 | + | |
| 55 | +# Extracting the source inserted above into the file sievegforth.fs | |
| 56 | +../bif-img --to-eoln-text sieveplay.dsk -- -off=50 -count=3 > sievegforth.fs | |
| 57 | + | |
| 58 | +# With line numbers: | |
| 59 | +../bif-img --to-eoln-text sieveplay.dsk -- -off=44 -count=6 | cat -n | |
| 60 | + |
| @@ -1,22 +1,25 @@ | ||
| 1 | -( from rosetta code ) | |
| 2 | -: prime? ( n -- ? ) | |
| 1 | +( FROM ROSETTA CODE ) | |
| 2 | + | |
| 3 | +( https://rosettacode.org/wiki/Sieve_of_Eratosthenes#Forth ) | |
| 4 | + | |
| 5 | +: PRIME? ( N -- ? ) | |
| 3 | 6 | HERE + C@ 0= ; |
| 4 | 7 | |
| 5 | -: composite! ( n -- ) | |
| 8 | +: COMPOSITE! ( N -- ) | |
| 6 | 9 | HERE + 1 SWAP C! ; |
| 7 | 10 | |
| 8 | -( : 2dup OVER OVER ; ) | |
| 11 | +: 2DUP OVER OVER ; | |
| 9 | 12 | |
| 10 | -: showPrimes | |
| 11 | - ." Primes: " | |
| 12 | - 2 DO I prime? | |
| 13 | +: SHOWPRIMES | |
| 14 | + ." PRIMES: " | |
| 15 | + 2 DO I PRIME? | |
| 13 | 16 | IF I . ENDIF |
| 14 | 17 | LOOP ; |
| 15 | 18 | |
| 16 | -: countPrimes | |
| 17 | - ." Prime count: " | |
| 19 | +: COUNTPRIMES | |
| 20 | + ." PRIME COUNT: " | |
| 18 | 21 | 0 SWAP |
| 19 | - 2 DO I prime? | |
| 22 | + 2 DO I PRIME? | |
| 20 | 23 | IF 1+ ENDIF |
| 21 | 24 | LOOP |
| 22 | 25 | . ; |
| @@ -28,33 +31,44 @@ | ||
| 28 | 31 | |
| 29 | 32 | |
| 30 | 33 | |
| 31 | - | |
| 32 | - | |
| 33 | - | |
| 34 | -: sieve ( n -- ) | |
| 34 | +: SIEVE ( N -- ) | |
| 35 | 35 | HERE OVER ERASE |
| 36 | 36 | 2 |
| 37 | 37 | BEGIN |
| 38 | - 2dup DUP * > | |
| 38 | + 2DUP DUP * > | |
| 39 | 39 | WHILE |
| 40 | - DUP prime? IF | |
| 41 | - 2dup DUP * DO | |
| 42 | - I composite! | |
| 40 | + DUP PRIME? IF | |
| 41 | + 2DUP DUP * DO | |
| 42 | + I COMPOSITE! | |
| 43 | 43 | DUP +LOOP |
| 44 | 44 | ENDIF |
| 45 | 45 | 1+ |
| 46 | 46 | REPEAT |
| 47 | 47 | DROP |
| 48 | 48 | ; |
| 49 | +--> | |
| 50 | +( SIEVE DEFINED. ) | |
| 51 | + | |
| 52 | +( EDIT SIEVE COUNT TO DO MORE ) | |
| 53 | + | |
| 54 | +( SIEVE IS KEPT IN THE ) | |
| 55 | +( FREE RAM AREA, ) | |
| 56 | +( WITH THE EXPECT-ED ) | |
| 57 | +( CONSEQUENCES. ) | |
| 58 | + | |
| 59 | +( MAY MISBEHAVE ) | |
| 60 | +( IF RUN TWICE IN A ROW ) | |
| 61 | +( WITHOUT REPEAL-ING BACK. ) | |
| 49 | 62 | |
| 50 | 63 | |
| 51 | -100 sieve | |
| 64 | +( OKAY UP TO AT LEAST 8192. ) | |
| 65 | +100 SIEVE | |
| 52 | 66 | |
| 53 | -dup | |
| 67 | +DUP | |
| 54 | 68 | |
| 55 | -showPrimes | |
| 69 | +SHOWPRIMES | |
| 56 | 70 | |
| 57 | -countPrimes | |
| 71 | +COUNTPRIMES | |
| 58 | 72 | |
| 59 | 73 | |
| 60 | 74 |
| @@ -1,28 +1,28 @@ | ||
| 1 | -( Archetypical implementation ) | |
| 2 | -( of the sieve of eratosthenes ) | |
| 3 | -( in FORTH -- fig, bif-c -- ) | |
| 4 | -( using more ) | |
| 5 | -( of the FORTH idiom. ) | |
| 6 | -( Copyright 2015, 2019, | |
| 7 | -( Joel Matthew Rees ) | |
| 8 | -( By Joel Matthew Rees, ) | |
| 9 | -( Amagasaki, Japan, 2015 ) | |
| 10 | -( All rights reserved. ) | |
| 11 | -( Permission granted by the ) | |
| 12 | -( author to use this code ) | |
| 13 | -( for any purpose, ) | |
| 14 | -( on condition that ) | |
| 15 | -( substantial use ) | |
| 16 | -( shall retain this copyright ) | |
| 17 | -( and permission notice. ) | |
| 18 | - | |
| 19 | - | |
| 20 | - | |
| 21 | -VOCABULARY sieve-local | |
| 22 | -( Make a local symbol table. ) | |
| 23 | -sieve-local DEFINITIONS | |
| 24 | -( Switch to the ) | |
| 25 | -( local vocabulary. ) | |
| 1 | +( ARCHETYPICAL IMPLEMENTATION ) | |
| 2 | +( OF THE SIEVE OF ERATOSTHENES ) | |
| 3 | +( IN FORTH -- BIF, FIG -- ) | |
| 4 | +( USING A LITTLE MORE ) | |
| 5 | +( OF THE FORTH AND BIF IDIOMS. ) | |
| 6 | +( COPYRIGHT 2015, 2019, | |
| 7 | +( JOEL MATTHEW REES ) | |
| 8 | +( BY JOEL MATTHEW REES, ) | |
| 9 | +( AMAGASAKI, JAPAN, 2015 ) | |
| 10 | +( ALL RIGHTS RESERVED. ) | |
| 11 | +( PERMISSION GRANTED BY THE ) | |
| 12 | +( AUTHOR TO USE THIS CODE ) | |
| 13 | +( FOR ANY PURPOSE, ) | |
| 14 | +( ON CONDITION THAT ) | |
| 15 | +( SUBSTANTIAL USE ) | |
| 16 | +( SHALL RETAIN THIS COPYRIGHT ) | |
| 17 | +( AND PERMISSION NOTICE. ) | |
| 18 | + | |
| 19 | +( PERL-ESQUE, TOO. ) | |
| 20 | + | |
| 21 | +VOCABULARY SIEVE-LOCAL | |
| 22 | +( MAKE A LOCAL SYMBOL TABLE. ) | |
| 23 | +SIEVE-LOCAL DEFINITIONS | |
| 24 | +( SWITCH TO THE ) | |
| 25 | +( LOCAL VOCABULARY. ) | |
| 26 | 26 | |
| 27 | 27 | |
| 28 | 28 | 256 CONSTANT MAXSIEVE |
| @@ -32,92 +32,60 @@ MAXSIEVE 1 - 2 / | ||
| 32 | 32 | |
| 33 | 33 | |
| 34 | 34 | 5 CONSTANT DISPWIDTH |
| 35 | -( enough digits ) | |
| 36 | -( to display MAXSIEVE ) | |
| 35 | +( ENOUGH DIGITS ) | |
| 36 | +( TO DISPLAY MAXSIEVE ) | |
| 37 | 37 | |
| 38 | 38 | |
| 39 | -0 VARIABLE sieve | |
| 40 | -( Old FORTHs don't provide a ) | |
| 41 | -( default behavior for CREATE ) | |
| 42 | -( gforth will leave ) | |
| 43 | -( the zero there. ) | |
| 44 | -( Old FORTHs need ) | |
| 45 | -( an initial value. ) | |
| 46 | - | |
| 47 | - HERE sieve - DUP | |
| 48 | -( Old FORTHs don't provide ) | |
| 49 | -( a CELL width. ) | |
| 50 | - MAXSIEVE SWAP - ALLOT | |
| 51 | -( Allocate the rest ) | |
| 52 | -( of the byte array. ) | |
| 39 | +0 VARIABLE SIEVE | |
| 40 | +( OLD FORTHS DON'T PROVIDE A ) | |
| 41 | +( DEFAULT BEHAVIOR FOR CREATE ) | |
| 42 | +( GFORTH WILL LEAVE ) | |
| 43 | +( THE ZERO THERE. ) | |
| 44 | +( OLD FORTHS NEED ) | |
| 45 | +( AN INITIAL VALUE. ) | |
| 53 | 46 | |
| 47 | + HERE SIEVE - | |
| 48 | +( OLD FORTHS DON'T PROVIDE ) | |
| 49 | +( A CELL WIDTH. ) | |
| 54 | 50 | CONSTANT CELLWIDTH |
| 55 | -( To show how it can be done. ) | |
| 56 | - | |
| 57 | - --> | |
| 58 | - | |
| 59 | - | |
| 60 | - | |
| 61 | - | |
| 62 | - | |
| 63 | - | |
| 64 | - | |
| 65 | - | |
| 66 | -: sieveInit ( -- adr ) | |
| 67 | -0 sieve C! | |
| 68 | -( 0 is not prime. ) | |
| 69 | -0 sieve 1+ C! | |
| 70 | -( 1 is not prime. ) | |
| 71 | -sieve MAXSIEVE 2 DO | |
| 72 | -( set flags to true ) | |
| 73 | -( for 2 to FINALPASS. ) | |
| 74 | - -1 OVER I + C! LOOP | |
| 75 | -( sieve pointer -- ) | |
| 76 | -( still on stack. ) | |
| 77 | -; | |
| 78 | - | |
| 79 | - --> | |
| 80 | - | |
| 81 | - | |
| 82 | - | |
| 83 | - | |
| 84 | - | |
| 85 | - | |
| 86 | - | |
| 87 | - | |
| 88 | - | |
| 89 | - | |
| 90 | - | |
| 51 | +( TO SHOW HOW IT CAN BE DONE. ) | |
| 91 | 52 | |
| 53 | +CELLWIDTH MAXSIEVE SWAP - ALLOT | |
| 54 | +( ALLOCATE THE REST ) | |
| 55 | +( OF THE BYTE ARRAY. ) | |
| 92 | 56 | |
| 57 | +: NOT-PRIME! ( ADR N -- ) | |
| 58 | ++ 0 SWAP ! ; | |
| 93 | 59 | |
| 60 | +: IS-PRIME? ( ADR N -- F ) | |
| 61 | ++ @ ; | |
| 62 | + --> | |
| 94 | 63 | |
| 95 | 64 | |
| 65 | +: SIEVE-INIT ( ADR -- ) | |
| 66 | +0 OVER C! | |
| 67 | +( 0 IS NOT PRIME. ) | |
| 68 | +0 OVER 1+ C! | |
| 69 | +( 1 IS NOT PRIME. ) | |
| 70 | +( SET FLAGS TO TRUE ) | |
| 71 | +( FOR 2 TO FINALPASS. ) | |
| 72 | +2+ MAXSIEVE 2- -1 FILL | |
| 73 | + ; | |
| 96 | 74 | |
| 97 | 75 | |
| 98 | -: primePass ( adr prime -- adr ) | |
| 76 | +: PRIME-PASS ( ADR PRIME -- ) | |
| 77 | +( DOUBLE IS FIRST MULTIPLE ) | |
| 99 | 78 | MAXSIEVE OVER DUP + DO |
| 100 | -( start at first multiple ) | |
| 101 | -( -- double. ) | |
| 102 | - OVER I + 0 SWAP C! | |
| 103 | -( clear at this multiple. ) | |
| 104 | - DUP +LOOP | |
| 105 | -( next multiple ) | |
| 79 | + OVER I NOT-PRIME! | |
| 80 | + DUP +LOOP ( NEXT MULTIPLE ) | |
| 106 | 81 | DROP ; |
| 107 | -( sieve address still ) | |
| 108 | -( on stack. ) | |
| 109 | 82 | |
| 110 | -: findPrimes ( adr -- adr ) | |
| 83 | +: FIND-PRIMES ( ADR -- ) | |
| 111 | 84 | FINALPASS 2 DO |
| 112 | -( clear flags ) | |
| 113 | -( at all multiples. ) | |
| 114 | - DUP I + C@ IF | |
| 115 | -( don't bother if not prime. ) | |
| 116 | - I primePass | |
| 85 | + DUP I IS-PRIME? IF | |
| 86 | + I PRIME-PASS | |
| 117 | 87 | ENDIF |
| 118 | 88 | LOOP ; |
| 119 | -( sieve still on stack. ) | |
| 120 | - | |
| 121 | 89 | |
| 122 | 90 | --> |
| 123 | 91 |
| @@ -126,29 +94,49 @@ LOOP ; | ||
| 126 | 94 | |
| 127 | 95 | |
| 128 | 96 | |
| 97 | +: COUNT-PRIMES ( ADR -- ) | |
| 98 | +." COUNT: " . | |
| 99 | +0 SWAP | |
| 100 | +MAXSIEVE 0 DO | |
| 101 | + DUP I IS-PRIME? IF | |
| 102 | + SWAP 1+ SWAP | |
| 103 | + ENDIF | |
| 104 | +LOOP DROP CR | |
| 105 | + ; | |
| 129 | 106 | |
| 130 | 107 | |
| 108 | +: PRINT-ALL ( ADR -- ) | |
| 109 | +MAXSIEVE 0 DO | |
| 110 | + I DISPWIDTH .R ." : IS " | |
| 111 | + DUP I IS-PRIME? 0= IF | |
| 112 | + ." NOT " | |
| 113 | + ENDIF | |
| 114 | + ." PRIME." CR | |
| 115 | +LOOP | |
| 116 | +DROP ; | |
| 131 | 117 | |
| 132 | 118 | |
| 133 | - | |
| 134 | -: printPrimes ( adr -- ) | |
| 119 | +: PRINT-PRIMES ( ADR -- ) | |
| 135 | 120 | MAXSIEVE 0 DO |
| 136 | - I DISPWIDTH .R ." : is " | |
| 137 | - DUP I + C@ 0= IF | |
| 138 | - ." not " | |
| 139 | - ENDIF | |
| 140 | - ." prime." CR | |
| 141 | -LOOP DROP ; | |
| 121 | + DUP I IS-PRIME? | |
| 122 | + IF . ENDIF | |
| 123 | +LOOP | |
| 124 | +DROP CR ; | |
| 125 | +--> | |
| 126 | + | |
| 127 | + | |
| 142 | 128 | |
| 143 | 129 | |
| 144 | -FORTH DEFINITIONS | |
| 130 | +BIF DEFINITIONS | |
| 145 | 131 | |
| 146 | -: sieveMain ( -- ) | |
| 147 | -[ sieve-local ] sieveInit | |
| 148 | -findPrimes | |
| 149 | -printPrimes ; | |
| 132 | +: SIEVEMAIN ( -- ) | |
| 133 | +[ SIEVE-LOCAL ] | |
| 134 | +SIEVE SIEVE-INIT | |
| 135 | +SIEVE FIND-PRIMES | |
| 136 | +SIEVE PRINT-PRIMES | |
| 137 | +SIEVE COUNT-PRIMES ; | |
| 150 | 138 | |
| 151 | 139 | |
| 152 | -sieveMain | |
| 140 | +SIEVEMAIN | |
| 153 | 141 | |
| 154 | 142 |
| @@ -1,67 +1,68 @@ | ||
| 1 | -( Archetypical implementation ) | |
| 2 | -( of the sieve of eratosthenes ) | |
| 3 | -( in FORTH -- BIF-6809 -- ) | |
| 4 | -( Copyright 2015, 2019, ) | |
| 5 | -( Joel Matthew Rees ) | |
| 6 | -( Written by Joel Mathew Rees, ) | |
| 7 | -( Amagasaki, Japan, 2015, 2019 ) | |
| 8 | -( All rights reserved. ) | |
| 9 | -( Permission granted by the ) | |
| 10 | -( author to use this code ) | |
| 11 | -( for any purpose, ) | |
| 12 | -( on condition that ) | |
| 13 | -( substantial use ) | |
| 14 | -( shall retain this copyright ) | |
| 15 | -( and permission notice. ) | |
| 1 | +( ARCHETYPICAL IMPLEMENTATION ) | |
| 2 | +( OF THE SIEVE OF ERATOSTHENES ) | |
| 3 | +( IN FORTH -- BIF-6809 -- ) | |
| 4 | +( COPYRIGHT 2015, 2019, ) | |
| 5 | +( JOEL MATTHEW REES ) | |
| 6 | +( WRITTEN BY JOEL MATHEW REES, ) | |
| 7 | +( AMAGASAKI, JAPAN, 2015, 2019 ) | |
| 8 | +( ALL RIGHTS RESERVED. ) | |
| 9 | +( PERMISSION GRANTED BY THE ) | |
| 10 | +( AUTHOR TO USE THIS CODE ) | |
| 11 | +( FOR ANY PURPOSE, ) | |
| 12 | +( ON CONDITION THAT ) | |
| 13 | +( SUBSTANTIAL USE ) | |
| 14 | +( SHALL RETAIN THIS COPYRIGHT ) | |
| 15 | +( AND PERMISSION NOTICE. ) | |
| 16 | 16 | |
| 17 | -256 constant MAXSIEVE | |
| 17 | +256 CONSTANT MAXSIEVE | |
| 18 | 18 | MAXSIEVE 1- 2 / |
| 19 | - constant FINALPASS | |
| 19 | + CONSTANT FINALPASS | |
| 20 | 20 | |
| 21 | -5 constant DISPWIDTH | |
| 22 | -( enough digits ) | |
| 23 | -( to display MAXSIEVE ) | |
| 21 | +5 CONSTANT DISPWIDTH | |
| 22 | +( ENOUGH DIGITS ) | |
| 23 | +( TO DISPLAY MAXSIEVE ) | |
| 24 | 24 | |
| 25 | -create sieve MAXSIEVE allot | |
| 25 | +CREATE SIEVE MAXSIEVE ALLOT | |
| 26 | 26 | |
| 27 | 27 | --> |
| 28 | 28 | |
| 29 | 29 | |
| 30 | 30 | |
| 31 | 31 | |
| 32 | -: sieveMain ( -- ) | |
| 33 | -0 sieve c! | |
| 34 | -( 0 is not prime. ) | |
| 35 | -0 sieve 1+ c! | |
| 36 | -( 1 is not prime. ) | |
| 37 | -sieve MAXSIEVE 2 do | |
| 38 | -( set flags to true ) | |
| 39 | -( for 2 to FINALPASS. ) | |
| 40 | - -1 over i + c! loop | |
| 41 | -( sieve ptr still on stack. ) | |
| 42 | -FINALPASS 2 do | |
| 43 | -( clear flags at multiples. ) | |
| 44 | - dup i + c@ if | |
| 45 | -( don't bother if not prime. ) | |
| 46 | - MAXSIEVE i dup + ?do | |
| 47 | -( start at first multiple ) | |
| 48 | -( -- double. ) | |
| 49 | - 0 over i + c! | |
| 50 | -( clear at this multiple. ) | |
| 51 | - j +loop | |
| 52 | -( sieve still on stack. ) | |
| 53 | - then | |
| 54 | -loop ( sieve still on stack. ) | |
| 55 | -MAXSIEVE 0 do | |
| 56 | - i DISPWIDTH .r ." : is " | |
| 57 | - dup i + c@ 0= if | |
| 58 | - ." not " | |
| 59 | - then | |
| 60 | - ." prime." cr | |
| 61 | -loop drop ; | |
| 32 | + | |
| 33 | +: SIEVEMAIN ( -- ) | |
| 34 | +0 SIEVE C! | |
| 35 | +( 0 IS NOT PRIME. ) | |
| 36 | +0 SIEVE 1+ C! | |
| 37 | +( 1 IS NOT PRIME. ) | |
| 38 | +SIEVE MAXSIEVE 2 DO | |
| 39 | +( SET FLAGS TO TRUE ) | |
| 40 | +( FOR 2 TO FINALPASS. ) | |
| 41 | + -1 OVER I + C! LOOP | |
| 42 | +( SIEVE PTR STILL ON STACK. ) | |
| 43 | +FINALPASS 2 DO | |
| 44 | +( CLEAR FLAGS AT MULTIPLES. ) | |
| 45 | + DUP I + C@ IF | |
| 46 | +( DON'T BOTHER IF NOT PRIME. ) | |
| 47 | + MAXSIEVE I DUP + ?DO | |
| 48 | +( START AT FIRST MULTIPLE ) | |
| 49 | +( -- DOUBLE. ) | |
| 50 | + 0 OVER I + C! | |
| 51 | +( CLEAR AT THIS MULTIPLE. ) | |
| 52 | + J +LOOP | |
| 53 | +( SIEVE STILL ON STACK. ) | |
| 54 | + THEN | |
| 55 | +LOOP ( SIEVE STILL ON STACK. ) | |
| 56 | +MAXSIEVE 0 DO | |
| 57 | + I DISPWIDTH .R ." : IS " | |
| 58 | + DUP I + C@ 0= IF | |
| 59 | + ." NOT " | |
| 60 | + THEN | |
| 61 | + ." PRIME." CR | |
| 62 | +LOOP DROP ; | |
| 62 | 63 | --> |
| 63 | 64 | |
| 64 | 65 | |
| 65 | -sieveMain | |
| 66 | +SIEVEMAIN | |
| 66 | 67 | |
| 67 | 68 |
Fork