• R/O
  • HTTP
  • SSH
  • HTTPS

bif-6809: コミット

ソースコード及び仕様書など
Source and documentation


コミットメタ情報

リビジョンf2ca6c0eaf45226c1fda1b41a264196bd643729a (tree)
日時2019-05-02 17:55:30
作者Joel Matthew Rees <joel.rees@gmai...>
コミッターJoel Matthew Rees

ログメッセージ

still trying to make the sieve stuff work.
rs_sieve_bif.fs at least works.
Using the image sieveplay.dsk.

変更サマリ

差分

--- a/bif-img.c
+++ b/bif-img.c
@@ -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
--- a/commands.txt
+++ b/commands.txt
@@ -45,3 +45,16 @@ imgtool get coco_jvc_rsdos ../../foreign6809/play/play.dsk PRIMES.BAS --filter=a
4545
4646 dd if=/dev/zero of=blank.dsk bs=256 count=630
4747
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+
--- a/testsource/rs_sieve_bif.fs
+++ b/testsource/rs_sieve_bif.fs
@@ -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 -- ? )
36 HERE + C@ 0= ;
47
5-: composite! ( n -- )
8+: COMPOSITE! ( N -- )
69 HERE + 1 SWAP C! ;
710
8-( : 2dup OVER OVER ; )
11+: 2DUP OVER OVER ;
912
10-: showPrimes
11- ." Primes: "
12- 2 DO I prime?
13+: SHOWPRIMES
14+ ." PRIMES: "
15+ 2 DO I PRIME?
1316 IF I . ENDIF
1417 LOOP ;
1518
16-: countPrimes
17- ." Prime count: "
19+: COUNTPRIMES
20+ ." PRIME COUNT: "
1821 0 SWAP
19- 2 DO I prime?
22+ 2 DO I PRIME?
2023 IF 1+ ENDIF
2124 LOOP
2225 . ;
@@ -28,33 +31,44 @@
2831
2932
3033
31-
32-
33-
34-: sieve ( n -- )
34+: SIEVE ( N -- )
3535 HERE OVER ERASE
3636 2
3737 BEGIN
38- 2dup DUP * >
38+ 2DUP DUP * >
3939 WHILE
40- DUP prime? IF
41- 2dup DUP * DO
42- I composite!
40+ DUP PRIME? IF
41+ 2DUP DUP * DO
42+ I COMPOSITE!
4343 DUP +LOOP
4444 ENDIF
4545 1+
4646 REPEAT
4747 DROP
4848 ;
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. )
4962
5063
51-100 sieve
64+( OKAY UP TO AT LEAST 8192. )
65+100 SIEVE
5266
53-dup
67+DUP
5468
55-showPrimes
69+SHOWPRIMES
5670
57-countPrimes
71+COUNTPRIMES
5872
5973
6074
--- a/testsource/sievefig.bif6809
+++ b/testsource/sievefig.bif6809
@@ -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. )
2626
2727
2828 256 CONSTANT MAXSIEVE
@@ -32,92 +32,60 @@ MAXSIEVE 1 - 2 /
3232
3333
3434 5 CONSTANT DISPWIDTH
35-( enough digits )
36-( to display MAXSIEVE )
35+( ENOUGH DIGITS )
36+( TO DISPLAY MAXSIEVE )
3737
3838
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. )
5346
47+ HERE SIEVE -
48+( OLD FORTHS DON'T PROVIDE )
49+( A CELL WIDTH. )
5450 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. )
9152
53+CELLWIDTH MAXSIEVE SWAP - ALLOT
54+( ALLOCATE THE REST )
55+( OF THE BYTE ARRAY. )
9256
57+: NOT-PRIME! ( ADR N -- )
58++ 0 SWAP ! ;
9359
60+: IS-PRIME? ( ADR N -- F )
61++ @ ;
62+ -->
9463
9564
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+ ;
9674
9775
98-: primePass ( adr prime -- adr )
76+: PRIME-PASS ( ADR PRIME -- )
77+( DOUBLE IS FIRST MULTIPLE )
9978 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 )
10681 DROP ;
107-( sieve address still )
108-( on stack. )
10982
110-: findPrimes ( adr -- adr )
83+: FIND-PRIMES ( ADR -- )
11184 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
11787 ENDIF
11888 LOOP ;
119-( sieve still on stack. )
120-
12189
12290 -->
12391
@@ -126,29 +94,49 @@ LOOP ;
12694
12795
12896
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+ ;
129106
130107
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 ;
131117
132118
133-
134-: printPrimes ( adr -- )
119+: PRINT-PRIMES ( ADR -- )
135120 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+
142128
143129
144-FORTH DEFINITIONS
130+BIF DEFINITIONS
145131
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 ;
150138
151139
152-sieveMain
140+SIEVEMAIN
153141
154142
--- a/testsource/sievegforth.bif6809
+++ b/testsource/sievegforth.bif6809
@@ -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. )
1616
17-256 constant MAXSIEVE
17+256 CONSTANT MAXSIEVE
1818 MAXSIEVE 1- 2 /
19- constant FINALPASS
19+ CONSTANT FINALPASS
2020
21-5 constant DISPWIDTH
22-( enough digits )
23-( to display MAXSIEVE )
21+5 CONSTANT DISPWIDTH
22+( ENOUGH DIGITS )
23+( TO DISPLAY MAXSIEVE )
2424
25-create sieve MAXSIEVE allot
25+CREATE SIEVE MAXSIEVE ALLOT
2626
2727 -->
2828
2929
3030
3131
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 ;
6263 -->
6364
6465
65-sieveMain
66+SIEVEMAIN
6667
6768
旧リポジトリブラウザで表示