From: Tim Vaughan <tgvaughan@gmail.com>
Date: Tue, 26 Apr 2016 08:48:23 +0000 (+1200)
Subject: Working on LEAVE and example.
X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=ece6e5acc36b0b01b5abf93dde3858b37abd4874;p=forth.jl.git

Working on LEAVE and example.
---

diff --git a/examples/mandelbrot.4th b/examples/mandelbrot.4th
new file mode 100644
index 0000000..2767738
--- /dev/null
+++ b/examples/mandelbrot.4th
@@ -0,0 +1,42 @@
+( --- Complex integer arithmetic --- )
+
+: c* ( x1 y1 x2 y2 -- x3 y3 )
+        swap rot                ( x1 x2 y1 y2 )
+        2dup * negate           ( x1 x2 y1 y2 -y1y2 )
+        4 pick 4 pick * +       ( x1 x2 y1 y2 (x1x2-y1y2))
+        4 roll 2 roll *         ( x2 y1 (x1x2-y1y2) x1y2 )
+        3 roll 3 roll * +       ( (x1x2-y1y2) (x1y2+x2y1) )
+;
+
+: c+ ( x1 y1 x2 y2 -- x3 y3 )
+        rot +
+        -rot +
+        swap
+;
+
+: csq 2dup c* ;
+
+; cmagsq ( x1 y1 -- mag )
+        csq abs
+;
+
+( --- Mandelbrot set calculations  --- )
+
+: iterate ( cr ci zr zi -- cr ci z'r z'i )
+        csq c+
+;
+
+: inSet? ( cr ci -- res )
+    
+    100 0 DO
+
+        2SWAP 2DUP 5 ROLL 5 ROLL
+        iterate
+        2DUP cmagsq
+        100 > IF
+            LEAVE
+        THEN
+
+    LOOP
+;
+
diff --git a/src/forth.jl b/src/forth.jl
index 3a2509b..e2292e1 100644
--- a/src/forth.jl
+++ b/src/forth.jl
@@ -517,6 +517,11 @@ FROMR = defPrimWord("R>", () -> begin
     return NEXT
 end)
 
+RFETCH = defPrimWord("R@", () -> begin
+    pushPS(mem[reg.RSP])
+    return NEXT
+end)
+
 RSPFETCH = defPrimWord("RSP@", () -> begin
     pushPS(reg.RSP)
     return NEXT
diff --git a/src/lib.4th b/src/lib.4th
index 4b60a1e..b44fb65 100644
--- a/src/lib.4th
+++ b/src/lib.4th
@@ -1,5 +1,6 @@
-' 1+ , : / /MOD SWAP DROP ;
+: / /MOD SWAP DROP ;
 : MOD /MOD DROP ;
+: */ * / ;
 
 : '\n' 10 ;
 : BL 32 ;
@@ -105,16 +106,25 @@
 ;
 
 : DO IMMEDIATE
-        ' >R , ' >R ,
+        ' LIT , 
+        HERE @
+        0 ,
+        ' >R , ' >R , ' >R ,
         HERE @
 ;
 
+: I RSP@ 2- @ ;
+
+: LEAVE RDROP RDROP RDROP EXIT ;
+
 : LOOP IMMEDIATE
         ' R> , ' R> , ' 1+ , ' 2DUP , ' - ,
         ' SWAP , ' >R , ' SWAP , ' >R ,
         ' 0<= , ' 0BRANCH ,
         HERE @ - ,
-        ' RDROP , ' RDROP ,
+        ' RDROP , ' RDROP , ' RDROP ,
+        DUP HERE @ SWAP -
+        SWAP !
 ;
 
 
@@ -145,6 +155,7 @@
         @               ( and fetch )
 ;
 
+
 ( With the looping constructs, we can now write SPACES, which writes n spaces to stdout. )
 : SPACES        ( n -- )
         BEGIN
@@ -240,8 +251,6 @@
         U.
 ;
 
-: U. U. SPACE ;
-
 : . 0 .R SPACE ;
 
 : .S            ( -- )
@@ -256,6 +265,8 @@
         DROP
 ;
 
+: U. U. SPACE ;
+
 ( ? fetches the integer at an address and prints it. )
 : ? ( addr -- ) @ . ;