Fixed >scaled in example.

[forth.jl.git] / src / lib.4th

diff --git a/src/lib.4th b/src/lib.4th
index c9e07bf..ea4e7de 100644 (file)
--- a/src/lib.4th
+++ b/src/lib.4th
@@ -1,14 +1,8 @@
 : / /MOD SWAP DROP ;
 : MOD /MOD DROP ;
-: */ * / ;
+: */ -ROT * SWAP / ;
 
-: '\n' 10 ;
-: BL 32 ;
-
-: CR '\n' emit ;
-: SPACE BL emit ;
-
-: NEGATE 0 swap - ;
+: NEGATE 0 SWAP - ;
 
 : TRUE -1 ;
 : FALSE 0 ;
@@ -18,6 +12,9 @@
 
 : DEPTH PSP@ PSP0 @ - ;
 
+: '\n' 10 ;
+: BL 32 ;
+
 : LITERAL IMMEDIATE ' LIT , , ;
 
 : ':' [ CHAR : ] LITERAL ;
@@ -32,6 +29,9 @@
 : '-' [ CHAR - ] LITERAL ;
 : '.' [ CHAR . ] LITERAL ;
 
+: CR '\n' emit ;
+: SPACE BL emit ;
+
 : [COMPILE] IMMEDIATE
         WORD            \ get the next word
         FIND            \ find it in the dictionary
@@ -45,6 +45,9 @@
         ,               \ compile it
 ;
 
+: DEBUGON TRUE DEBUG ! ;
+: DEBUGOFF FALSE DEBUG ! ;
+
 \ CONTROL STRUCTURES ----------------------------------------------------------------------
 
 : IF IMMEDIATE
@@ -107,19 +110,40 @@
 
 : DO IMMEDIATE
         ' >R , ' >R ,
+        ' LIT , HERE @ 0 , ' >R ,
         HERE @
 ;
 
-: I RSP@ 2- @ ;
+: I RSP@ 3 - @ ;
 
-: LOOP IMMEDIATE
-        ' R> , ' R> , ' 1+ , ' 2DUP , ' - ,
-        ' SWAP , ' >R , ' SWAP , ' >R ,
+: J RSP@ 6 - @ ;
+
+: ?LEAVE IMMEDIATE
+        ' 0BRANCH , 13 ,
+        ' R> , ' RDROP , ' RDROP ,
+        ' LIT ,  HERE @ 7 + , ' DUP , ' -ROT , ' - , ' SWAP , ' ! ,
+        ' BRANCH ,
+        0 ,
+;
+
+: LEAVE IMMEDIATE
+        ' LIT , -1 ,
+        [COMPILE] ?LEAVE
+;
+
+: +LOOP IMMEDIATE
+        ' R> , ' SWAP , ' R> , ' SWAP , ' R> , ' SWAP , ' + , ' 2DUP , ' - ,
+        ' SWAP , ' >R , ' SWAP , ' >R , ' SWAP , ' >R ,
         ' 0<= , ' 0BRANCH ,
         HERE @ - ,
-        ' RDROP , ' RDROP ,
+        ' RDROP , ' RDROP , ' RDROP ,
+        HERE @ SWAP !
 ;
 
+: LOOP IMMEDIATE
+        ' LIT , 1 ,
+        [COMPILE] +LOOP
+;
 
 \ COMMENTS ----------------------------------------------------------------------
 
@@ -141,23 +165,18 @@
 
 ( Some more complicated stack examples, showing the stack notation. )
 : NIP ( x y -- y ) SWAP DROP ;
-: TUCK ( x y -- y x y ) DUP ROT ;
+: TUCK ( x y -- y x y ) DUP -ROT ;
 : PICK ( x_u ... x_1 x_0 u -- x_u ... x_1 x_0 x_u )
         1+              ( add one because of 'u' on the stack )
         PSP@ SWAP -     ( add to the stack pointer )
         @               ( and fetch )
 ;
 
-
 ( With the looping constructs, we can now write SPACES, which writes n spaces to stdout. )
 : SPACES        ( n -- )
-        BEGIN
-                DUP 0>          ( while n > 0 )
-        WHILE
-                SPACE           ( print a space )
-                1-              ( until we count down to 0 )
-        REPEAT
-        DROP
+        0 DO
+            SPACE
+        LOOP
 ;
 
 ( Standard words for manipulating BASE. )
@@ -165,12 +184,28 @@
 : HEX ( -- ) 16 BASE ! ;
 
 ( Compute absolute value. )
-: ABS           ( n -- m)
+: ABS           ( n -- |n| )
         dup 0< if
                 negate
         then
 ;
 
+: MAX           ( n m -- max )
+        2dup - 0< if
+                swap drop
+        else
+                drop
+        then
+;
+
+: MIN           ( n m -- max )
+        2dup - 0> if
+                swap drop
+        else
+                drop
+        then
+;
+
 ( PRINTING NUMBERS ---------------------------------------------------------------------- )
 
 ( This is the underlying recursive definition of U. )
@@ -205,7 +240,7 @@
         SWAP            ( width u )
         DUP             ( width u u )
         UWIDTH          ( width u uwidth )
-        -ROT            ( u uwidth width )
+        ROT            ( u uwidth width )
         SWAP -          ( u width-uwidth )
         ( At this point if the requested width is narrower, we'll have a negative number on the stack.
           Otherwise the number on the stack is the number of spaces to print.  But SPACES won't print
@@ -220,18 +255,18 @@
         DUP 0< IF
                 NEGATE          ( width u )
                 1               ( save a flag to remember that it was negative | width n 1 )
-                ROT             ( 1 width u )
+                -ROT             ( 1 width u )
                 SWAP            ( 1 u width )
                 1-              ( 1 u width-1 )
         ELSE
                 0               ( width u 0 )
-                ROT             ( 0 width u )
+                -ROT             ( 0 width u )
                 SWAP            ( 0 u width )
         THEN
         SWAP            ( flag width u )
         DUP             ( flag width u u )
         UWIDTH          ( flag width u uwidth )
-        -ROT            ( flag u uwidth width )
+        ROT            ( flag u uwidth width )
         SWAP -          ( flag u width-uwidth )
 
         SPACES          ( flag u )
@@ -265,7 +300,7 @@
 
 ( c a b WITHIN returns true if a <= c and c < b )
 : WITHIN
-        ROT             ( b c a )
+        -ROT             ( b c a )
         OVER            ( b c a c )
         <= IF
                 > IF            ( b c -- )
@@ -279,3 +314,13 @@
         THEN
 ;
 
+: ROLL ( x_u x_u-1... x_0 u -- x_u-1 ... x_0 x_u )
+        1+ DUP PICK SWAP    ( x_u x_u-1 ... x_0 x_u u+1 )
+        PSP@ 1- SWAP - PSP@ 2- SWAP
+        DO
+            i 1+ @ i !
+        LOOP
+        SWAP DROP
+;
+
+include ../examples/mandelbrot.4th