Source

Forth interpreter / ANSForth / forth.test

     1  2 +  .
marker beginning
2000000000 2000000000 + .
2000000000 2000000000 + u.
2,000,000,000 2,000,000,000 + d.
1,000 . .
-1, du.
: Five-more  5 + ;
4 five-more .
 ( first with spaces ) 1 2 + .
1 ( now no spaces)3 + .
: comment-test ( this is a cool test )3 2 + . ;
comment-test
7 8 * .
7 4 - .
21 4 / .
17 12 * 4 + .
3 9 + 4 6 + * .
23 4 mod .
22 4 /mod . .
: quarters  4 /mod . ." ones and " . ." quarters" ;
22 quarters
1 2 swap . .
2 10 4 - Swap / .
7 dup * .
3 5 OVER + * .
4 5 6 rot - * .
1 2 drop .
1, 2, 2swap d. d.
7, 2dup D+ d.
3, 5, 2OVER d- d- d.
4, 5, 6, 2rot d. d. d.
1, 2, 2drop d.
3 spaces cr space
42 emit
marker dummy
forget quarters
dummy
quarters
comment-test
beginning
beginning
comment-test
5 8 ' + execute ' . execute
: /CHECK  DUP 0= ABORT" zero denominator" / ;
9 2 /check .
: envelope 3 0 /check ;
envelope
: ?FULL  12 = IF  ." It's full "  THEN ;
11 ?full
12 ?full
: ?TOO-HOT  220 > IF ." Danger -- reduce heat" THEN ;
290 ?too-hot
130 ?too-hot
: EGGSIZE   DUP  18 < IF  ." reject "      ELSE
            DUP  21 < IF  ." small "       ELSE
            DUP  24 < IF  ." medium "      ELSE
            DUP  27 < IF  ." large "       ELSE
            DUP  30 < IF  ." extra large " ELSE
                      ." error "
            THEN THEN THEN THEN THEN DROP ;
23 eggsize
29 eggsize
5 eggsize
18 eggsize
24 eggsize
30 eggsize
: NUMTEST  IF ." non-" THEN ." zero " ;
0 numtest
1 numtest
-400 numtest
: ?DAY  DUP 1 <  SWAP 31 > +
        IF ." No way " ELSE ." Looks good " THEN ;
31 ?day
40 ?day
-59 ?day
10 ?day
-6 2 max 0 min 2+ 5 * negate 2/ 1 - abs 9 4 */ 4 5 */mod . .
200000000 200000000 100000000 */ .
: return-stack ( a b c -- ab + c )
>r * r> + ;
3 4 5 return-stack .
: QUADRATIC  ( a b c x -- n )
>R SWAP ROT R@ *  + R> *  + ;
2 7 9 3 quadratic .
: 34swap ( a b c d -- b a c d ) 2>r swap 2r> ;
2 1 3 4 34swap . . . .
: quadratic2  ( a b c x -- n )
dup 2>r swap rot r> *  + r> *  + ;
2 7 9 3 quadratic2 .
: sumsquare 2>r 2r@ + 2r> + * ;
1 2 . quit .
3 4 sumsquare .
.
: test-quit ?dup if . quit then ." zero" ;
2 3 test-quit 5 .
2 5 0 /check 10 .
.
0 test-quit
: PrintTo  >R  0  begin  dup .  1+  dup R@ =  until R> drop ;
7 printto
: PrintFrom  begin  dup  while  dup .  1-  repeat ;
5 printfrom
: HelloTest  10 0 DO  ." Hello "  LOOP ;
hellotest
: testplusloop do i . 4 +loop ;
6 0 testplusloop
4 0 testplusloop
: testminusloop do i . -2 +loop ;
-2 4 testminusloop
1 4 testminusloop
: MULTIPLICATIONS  11 1 DO  DUP I * .  LOOP  DROP ;
7 multiplications
: r% 100 */ ;
: COMPOUND ( amount interest -- )
           SWAP 6 1 DO  ." Year " I . 3 SPACES
                         2DUP R% +  DUP ." Balance " . CR
                   LOOP  2DROP ;
1000 6 compound
: RECTANGLE  16 0 DO   i 4 mod 0= IF  cr  THEN ." *" LOOP ;
rectangle quit
: POEM  CR 11 1 DO  I . ." Little "
                      I 3 MOD 0= IF ." indians " CR THEN
                 LOOP
           ." indian boys. " ;
poem
: TABLE  6 1 DO
              11 1 DO  I J *  .  LOOP
           CR LOOP ;
table
: INC-COUNT  DO  I . DUP +LOOP  DROP ;
-3 -10 10 inc-count
: DOUBLING   32767 1 DO  I . I +LOOP ;
20000 doubling
: DOUBLED
     6 1 DO  ." Year " I .
           2DUP R% +  DUP ."    Balance " . cr
           DUP 2000 > IF ." More than doubled in "
                             I . ." years " LEAVE
                    THEN
      LOOP 2DROP ;
10 1000 doubled
20 1000 doubled
1 . exit 2 .
: nothing 5 0 do leave i . loop ;
nothing
: apl-2d-iota 1+ swap 1+ 1 do
                dup 1 do
                     j . i . dup i 1+ = if leave then 2 spaces
                      loop
                  cr loop drop ;
2 3 apl-2d-iota
: prime-finder ( low-limit high-limit -- prime | 0 )
    swap do 
      i 2 do
          j i mod 0= if leave then
          i j 2/ > if j unloop unloop exit then
          loop
    loop 0 ;
: prime-envelope prime-finder ?dup if ." Found a prime - " . else ." No prime found " then ;
32 40 prime-envelope
32 35 prime-envelope
1002 1100 prime-envelope
5 2 um* 2dup d. 3 um/mod . .
-1 2 < . -1 2 u< .
: ** 1 swap 0 ?do over * loop nip ;