From f2ca6c0eaf45226c1fda1b41a264196bd643729a Mon Sep 17 00:00:00 2001 From: Joel Matthew Rees Date: Thu, 2 May 2019 17:55:30 +0900 Subject: [PATCH] still trying to make the sieve stuff work. rs_sieve_bif.fs at least works. Using the image sieveplay.dsk. --- bif-img.c | 2 +- commands.txt | 13 +++ testsource/rs_sieve_bif.fs | 58 +++++++----- testsource/sievefig.bif6809 | 204 +++++++++++++++++++---------------------- testsource/sievegforth.bif6809 | 105 ++++++++++----------- 5 files changed, 199 insertions(+), 183 deletions(-) diff --git a/bif-img.c b/bif-img.c index 5848de0..e7034ca 100644 --- a/bif-img.c +++ b/bif-img.c @@ -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 #include #include /* for EXIT_SUCCESS */ #include #include #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, "<>\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 [ %s= ] [ %s= ] [ %s= ] [ %s= ]\n", argv[ 0 ], kTo_ScreenStr, kBlockSizeStr, kBlockWidthStr, kBlockOffsetStr, kBlockCountStr ); printf( "\t%s %s [ %s= ] [ %s= ] [ %s= ] [ %s= ] [ %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 with -- for stdfiles in pipes\n" ); /* printf( "\t%s --to-image \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 +/* 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 #include #include /* for EXIT_SUCCESS */ #include #include #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, "<>\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 [ %s= ] [ %s= ] [ %s= ] [ %s= ]\n", argv[ 0 ], kTo_ScreenStr, kBlockSizeStr, kBlockWidthStr, kBlockOffsetStr, kBlockCountStr ); printf( "\t%s %s [ %s= ] [ %s= ] [ %s= ] [ %s= ] [ %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 with -- for stdfiles in pipes\n" ); /* printf( "\t%s --to-image \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 diff --git a/commands.txt b/commands.txt index 7eff8a7..619ea5b 100644 --- a/commands.txt +++ b/commands.txt @@ -45,3 +45,16 @@ imgtool get coco_jvc_rsdos ../../foreign6809/play/play.dsk PRIMES.BAS --filter=a dd if=/dev/zero of=blank.dsk bs=256 count=630 +# Compiling bif-img: +cc -Wall -o bif-img bif-img.c + +# Inserting variable line source in sievegforth.bif6809 +# into disk image sieveplay.dsk at SCREEN 50: +../bif-img --to-screens sievegforth.bif6809 sieveplay.dsk -off=50 + +# Extracting the source inserted above into the file sievegforth.fs +../bif-img --to-eoln-text sieveplay.dsk -- -off=50 -count=3 > sievegforth.fs + +# With line numbers: +../bif-img --to-eoln-text sieveplay.dsk -- -off=44 -count=6 | cat -n + diff --git a/testsource/rs_sieve_bif.fs b/testsource/rs_sieve_bif.fs index 41e0895..532ca3d 100644 --- a/testsource/rs_sieve_bif.fs +++ b/testsource/rs_sieve_bif.fs @@ -1,22 +1,25 @@ -( from rosetta code ) -: prime? ( n -- ? ) +( FROM ROSETTA CODE ) + +( https://rosettacode.org/wiki/Sieve_of_Eratosthenes#Forth ) + +: PRIME? ( N -- ? ) HERE + C@ 0= ; -: composite! ( n -- ) +: COMPOSITE! ( N -- ) HERE + 1 SWAP C! ; -( : 2dup OVER OVER ; ) +: 2DUP OVER OVER ; -: showPrimes - ." Primes: " - 2 DO I prime? +: SHOWPRIMES + ." PRIMES: " + 2 DO I PRIME? IF I . ENDIF LOOP ; -: countPrimes - ." Prime count: " +: COUNTPRIMES + ." PRIME COUNT: " 0 SWAP - 2 DO I prime? + 2 DO I PRIME? IF 1+ ENDIF LOOP . ; @@ -28,33 +31,44 @@ - - - -: sieve ( n -- ) +: SIEVE ( N -- ) HERE OVER ERASE 2 BEGIN - 2dup DUP * > + 2DUP DUP * > WHILE - DUP prime? IF - 2dup DUP * DO - I composite! + DUP PRIME? IF + 2DUP DUP * DO + I COMPOSITE! DUP +LOOP ENDIF 1+ REPEAT DROP ; +--> +( SIEVE DEFINED. ) + +( EDIT SIEVE COUNT TO DO MORE ) + +( SIEVE IS KEPT IN THE ) +( FREE RAM AREA, ) +( WITH THE EXPECT-ED ) +( CONSEQUENCES. ) + +( MAY MISBEHAVE ) +( IF RUN TWICE IN A ROW ) +( WITHOUT REPEAL-ING BACK. ) -100 sieve +( OKAY UP TO AT LEAST 8192. ) +100 SIEVE -dup +DUP -showPrimes +SHOWPRIMES -countPrimes +COUNTPRIMES diff --git a/testsource/sievefig.bif6809 b/testsource/sievefig.bif6809 index 1320e32..cf02aea 100644 --- a/testsource/sievefig.bif6809 +++ b/testsource/sievefig.bif6809 @@ -1,28 +1,28 @@ -( 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 @@ -32,92 +32,60 @@ MAXSIEVE 1 - 2 / 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. ) - --> @@ -126,29 +94,49 @@ LOOP ; +: 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 diff --git a/testsource/sievegforth.bif6809 b/testsource/sievegforth.bif6809 index 88a68a5..aca59d7 100644 --- a/testsource/sievegforth.bif6809 +++ b/testsource/sievegforth.bif6809 @@ -1,67 +1,68 @@ -( 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 -- 2.11.0