forth

vitiral · Sep 13, 2020 · cce43bf · cce43bf
1 parent 4229b77
commit cce43bf
Showing 1 changed file with 94 additions and 44 deletions.
diff --git a/forth/my.fs b/forth/my.fs
@@ -18,24 +18,24 @@ cleared
 
 : done   ." <<" CR ;
 
-." 1 space   :" space done ;
-." 10 spaces :" 10 spaces done ;
-." 42 emit   :" 42 emit done ;
-." 10 + 3    :" 10 3 + . done ;
+." 1 space   :" space done
+." 10 spaces :" 10 spaces done
+." 42 emit   :" 42 emit done
+." 10 + 3    :" 10 3 + . done
 
 : YARDS  ( yard -- in ) 36 * ;
 : FT   ( ft -- in ) 12 * ;
 
 cleared
-." 10 yards 2 ft 5 in > in=" 10 YARDS 2 FT 5 + + . ." inches" done ;
+." 10 yards 2 ft 5 in > in=" 10 YARDS 2 FT 5 + + . ." inches" done
 
 : eq_1a ( a b c -- [a+b]/c ) -rot + swap / ;
 : eq_1b { a b c -- [a+b]/c } a b + c / ;
 : eq_1c { a b c | d -- [a+b]/c }  a b + to d d c / ;
 : eq_1_input ( -- a b c ) 10 20 2 ;
 
 cleared
-." equation 1 in 3 forms: " eq_1_input eq_1a . ." " eq_1_input eq_1b . ." " eq_1_input eq_1c . done ;
+." equation 1 in 3 forms: " eq_1_input eq_1a . ." " eq_1_input eq_1b . ." " eq_1_input eq_1c . done
 
 ( other stack operations: SWAP DUP OVER ROT -ROT DROP )
 ( 2 conterparts: 2SWAP 2DUP .. etc )
@@ -44,17 +44,17 @@ cleared
 : .CARTON_FULL   ( eggs -- ) 12 = IF ." It's full " ELSE ." Not full " THEN ;
 
 cleared
-." Carton full w/ 10? " 10 .carton_full done ;
-." Carton full w/ 2? " 2 .carton_full done ;
-." Carton full w/ 12? " 12 .carton_full done ;
-." Carton full w/ 13? " 13 .carton_full done ;
+." Carton full w/ 10? " 10 .carton_full done
+." Carton full w/ 2? " 2 .carton_full done
+." Carton full w/ 12? " 12 .carton_full done
+." Carton full w/ 13? " 13 .carton_full done
 
-." true=" TRUE . ." false=" false . done ;
+." true=" TRUE . ." false=" false . done
 
 cleared
-." -1  0= 0= -> -1 : " -1 0= 0= . done ;
-." 0   0= 0= -> 0 : " 0 0= 0= . done ;
-." 200 0= 0= -> -1 : " 200 0= 0= . done ;
+." -1  0= 0= -> -1 : " -1 0= 0= . done
+." 0   0= 0= -> 0 : " 0 0= 0= . done
+." 200 0= 0= -> -1 : " 200 0= 0= . done
 
 cleared
 : .SIGN
@@ -63,9 +63,9 @@ cleared
   ELSE ." ZERO "
   THEN THEN ;
 
-." sign 100: " 100 .SIGN done ;
-." sign -10: " -10 .SIGN done ;
-." sign 0: " 0 .SIGN done ;
+." sign 100: " 100 .SIGN done
+." sign -10: " -10 .SIGN done
+." sign 0: " 0 .SIGN done
 
 cleared
 : WITHIN ( n low high -- low <= n < high )
@@ -84,11 +84,11 @@ cleared
 : range 5 10 ;
 
 cleared
-." n=1 5 <= n < 10? " 1 range WITHIN .BOOL SPACE done ;
-." n=5 5 <= n < 10? " 5 range WITHIN .BOOL SPACE done ;
-." n=6 5 <= n < 10? " 6 range WITHIN .BOOL SPACE done ;
-." n=10 5 <= n < 10? " 10 range WITHIN .BOOL SPACE done ;
-." n=100 5 <= n < 10? " 100 range WITHIN .BOOL SPACE done ;
+." n=1 5 <= n < 10? " 1 range WITHIN .BOOL SPACE done
+." n=5 5 <= n < 10? " 5 range WITHIN .BOOL SPACE done
+." n=6 5 <= n < 10? " 6 range WITHIN .BOOL SPACE done
+." n=10 5 <= n < 10? " 10 range WITHIN .BOOL SPACE done
+." n=100 5 <= n < 10? " 100 range WITHIN .BOOL SPACE done
 
 ( using variables is SO much easier! )
 : within_b { n low high -- low <= n < high }
@@ -99,28 +99,28 @@ cleared
 
 cleared
 ." WITHIN_B: " CR ;
-." n=1 5 <= n < 10? " 1 range within_b .BOOL SPACE done ;
-." n=5 5 <= n < 10? " 5 range within_b .BOOL SPACE done ;
-." n=6 5 <= n < 10? " 6 range within_b .BOOL SPACE done ;
-." n=10 5 <= n < 10? " 10 range within_b .BOOL SPACE done ;
-." n=100 5 <= n < 10? " 100 range within_b .BOOL SPACE done ;
+." n=1 5 <= n < 10? " 1 range within_b .BOOL SPACE done
+." n=5 5 <= n < 10? " 5 range within_b .BOOL SPACE done
+." n=6 5 <= n < 10? " 6 range within_b .BOOL SPACE done
+." n=10 5 <= n < 10? " 10 range within_b .BOOL SPACE done
+." n=100 5 <= n < 10? " 100 range within_b .BOOL SPACE done
 
 cleared
 CR ." ### Ch5" CR ;
-." 1+-: " 0 1+ 1- . done ;
-." 2+-: " 0 2+ 2- . done ;
-." 2*/: " 1 2* 2/ . done ;
-." ABS 1 -1: " 1 ABS . -1 ABS . done ;
-." NEGATE 42: " 42 NEGATE . done ;
-." MIN 4 400: " 4 400 MIN . done ;
-." MAX 4 400: " 4 400 MAX . done ;
+." 1+-: " 0 1+ 1- . done
+." 2+-: " 0 2+ 2- . done
+." 2*/: " 1 2* 2/ . done
+." ABS 1 -1: " 1 ABS . -1 ABS . done
+." NEGATE 42: " 42 NEGATE . done
+." MIN 4 400: " 4 400 MIN . done
+." MAX 4 400: " 4 400 MAX . done
 
 cleared
 : DIFFERENCE   - ABS ;
-." Difference 37 52: " 37 52 DIFFERENCE . 52 37 DIFFERENCE . done ;
+." Difference 37 52: " 37 52 DIFFERENCE . 52 37 DIFFERENCE . done
 
 : SWAP_BACK   ( a b c -- b a c ) >R SWAP R> ;
-." SWAP BACK 1 2 3: " 1 2 3 SWAP_BACK .S 2drop drop done ;
+." SWAP BACK 1 2 3: " 1 2 3 SWAP_BACK .S 2drop drop done
 
 cleared
 : QUADRATIC ( a b c x -- ax^2 + bx + c )
@@ -131,19 +131,19 @@ cleared
   + + ;
 
 : Q_ABC 2 3 4 ;
-." QUADRATIC a=2 b=3 c=4" done ;
-." x=-2: " Q_ABC -2 QUADRATIC . done ;
-." x=0: " Q_ABC 0 QUADRATIC . done ;
-." x=1: " Q_ABC 1 QUADRATIC . done ;
-." x=2: " Q_ABC 2 QUADRATIC . done ;
-." x=5: " Q_ABC 5 QUADRATIC . done ;
+." QUADRATIC a=2 b=3 c=4" done
+." x=-2: " Q_ABC -2 QUADRATIC . done
+." x=0: " Q_ABC 0 QUADRATIC . done
+." x=1: " Q_ABC 1 QUADRATIC . done
+." x=2: " Q_ABC 2 QUADRATIC . done
+." x=5: " Q_ABC 5 QUADRATIC . done
 
 cleared
 : %   ( value perc -- result ) 100 */ ;
-." 32% of 225: " 225 32 % . done ;
+." 32% of 225: " 225 32 % . done
 : 4MAX ( a b c d -- maximum )
   MAX MAX MAX ;
-." max of 1 2 3 4: " 1 2 3 4 4MAX . done ;
+." max of 1 2 3 4: " 1 2 3 4 4MAX . done
 
 cleared
 CR ." #### Ch6: loops" CR
@@ -318,3 +318,53 @@ alohaComming
 ." (comming) aloha: " aloha done
 alohaGoing
 ." (going) aloha: " aloha done
+
+cleared
+: helloExit hello hello EXIT goodbye ;
+." helloExit: " helloExit done
+
+: helloQuit hello hello QUIT ." after quit? ";
+( ." helloQuit: " helloQuit done ) ( causes normal interpret loop, do not want )
+( ." After hello Quit" done )
+( ." Another" done )
+
+cleared
+( Hmm... pforth doesn't have CP defined? )
+( ." Next avaialbe cell in dictionary: " CP @ . done | not available )
+." Next availble cell: " here U. done
+." PAD size: " pad U. done
+." Stack pointer : " SP@ U. done
+." Stack pointer contents : " SP@ @ U. done
+42
+." Stack pointer contents after 42: " SP@ @ U. done
+drop
+
+cleared
+: myDup SP@ @ ; ( same as DUP )
+: dup[0] ( u0 -- u0 ) SP@ @ ;
+: dup[1] ( u1 u0 -- u1 u0 u1 ) SP@ CELL + @ ;
+: dup[2] ( u2 u1 u0 -- u2..u0 u2 ) SP@ 2 CELLS + @ ;
+: dup[3] ( u3 u2 u1 u0 -- u3..u0 ue ) SP@ 3 CELLS + @ ;
+: dup[4] ( u4 u3 u2 u1 u0 -- u4..u0 u4 ) SP@ 4 CELLS + @ ;
+
+1 2 3 4 5
+." Dups (1 2 3 4 5)" CR ;
+." My dup " myDup . done
+." dup[0]: " dup[0] . done
+." dup[1]: " dup[1] . done
+." dup[2]: " dup[2] . done
+." dup[3]: " dup[3] . done
+." dup[4]: " dup[4] . done
+
+: 2dup[0] ( u1 u0 -- u1 u0 u1 u0) dup[1] dup[1] ;
+: 2dup[1] ( u2 u1 u0 -- u2..u0 u1 u0) dup[2] dup[2] ;
+: 2dup[2] ( u3 u2 u1 u0 -- u3..u0 u2 u1) dup[3] dup[3] ;
+
+." 2dup[0]: " 2dup[0] SWAP . . done
+." 2dup[1]: " 2dup[1] SWAP . . done
+." 2dup[2]: " 2dup[2] SWAP . . done
+drop drop drop drop  drop
+
+cleared
+( ." Bottom of the stack: " S0 U. done | not included )
+