testsource/rs_sieve_bif.fs

   1 ( FROM ROSETTA CODE )
   2
   3 ( https://rosettacode.org/wiki/Sieve_of_Eratosthenes#Forth )
   4
   5 : PRIME? ( N -- ? )
   6   HERE + C@ 0= ;
   7
   8 : COMPOSITE! ( N -- )
   9   HERE + 1 SWAP C! ;
  10
  11 : 2DUP OVER OVER ;
  12
  13 : SHOWPRIMES
  14   ." PRIMES: "
  15   2 DO I PRIME?
  16     IF I . ENDIF
  17   LOOP ;
  18
  19 : COUNTPRIMES
  20   ." PRIME COUNT: "
  21   0 SWAP
  22   2 DO I PRIME?
  23     IF 1+ ENDIF
  24   LOOP
  25   . ;
  26
  27 -->
  28
  29
  30
  31
  32
  33
  34 : SIEVE ( N -- )
  35   HERE OVER ERASE
  36   2
  37   BEGIN
  38     2DUP DUP * >
  39   WHILE
  40     DUP PRIME? IF
  41       2DUP DUP * DO
  42         I COMPOSITE!
  43       DUP +LOOP
  44     ENDIF
  45     1+
  46   REPEAT
  47   DROP
  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. )
  62
  63
  64 ( OKAY UP TO AT LEAST 8192. )
  65 100     SIEVE
  66
  67 DUP
  68
  69 SHOWPRIMES
  70
  71 COUNTPRIMES
  72
  73
  74