buggy bif_img, but it works if you're careful and don't mind things sliding a line...

[bif-6809/bif-6809.git] / testsource / sievefig.bif6809

diff --git a/testsource/sievefig.bif6809 b/testsource/sievefig.bif6809
new file mode 100644 (file)
index 0000000..1320e32
--- /dev/null
+++ b/testsource/sievefig.bif6809
@@ -0,0 +1,154 @@
+( 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. )
+
+
+256 CONSTANT MAXSIEVE
+MAXSIEVE 1 - 2 /
+   CONSTANT FINALPASS
+ -->
+
+
+5 CONSTANT DISPWIDTH 
+( 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. )
+
+   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. )
+;
+
+ -->
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+: primePass ( adr prime -- adr )
+MAXSIEVE OVER DUP + DO    
+( start at first multiple )
+(  -- double. )
+   OVER I + 0 SWAP C!     
+( clear at this multiple. )
+   DUP +LOOP              
+( next multiple )
+DROP ;      
+( sieve address still )
+( on stack. )
+
+: findPrimes ( adr -- adr )
+FINALPASS 2 DO   
+( clear flags )
+( at all multiples. )
+   DUP I + C@ IF 
+( don't bother if not prime. )
+      I primePass
+   ENDIF
+LOOP ;           
+( sieve still on stack. )
+
+
+-->
+
+
+
+
+
+
+
+
+
+
+
+: printPrimes ( adr -- )
+MAXSIEVE 0 DO
+   I DISPWIDTH .R ." : is "
+   DUP I + C@ 0= IF
+      ." not "
+   ENDIF
+   ." prime." CR
+LOOP DROP ;
+
+
+FORTH DEFINITIONS
+
+: sieveMain ( -- )
+[ sieve-local ] sieveInit
+findPrimes
+printPrimes ;
+
+
+sieveMain
+
+