forth: Add step 3

forth/env.fs

@@ -0,0 +1,45 @@
+require types.fs
+
+MalType%
+   cell% field MalEnv/outer
+   cell% field MalEnv/data
+deftype MalEnv
+
+: MalEnv. { outer -- env }
+    MalEnv new { env }
+    outer env MalEnv/outer !
+    MalMap/Empty env MalEnv/data !
+    env ;
+
+: env/set { key val env -- }
+    key val env MalEnv/data @ assoc
+    env MalEnv/data ! ;
+
+: env/find { key env -- env-or-0 }
+    env
+    begin ( env )
+        dup 0 key rot MalEnv/data @ get ( env val-or-0 )
+        0= if ( env )
+            MalEnv/outer @ dup 0= ( env-or-0 done-looping? )
+        else
+            -1 \ found it! ( env -1 )
+        endif
+    until ;
+
+MalEnv
+  extend get { not-found key env -- }
+    key env env/find ( env-or-0 )
+    ?dup 0= if
+        not-found
+    else ( env )
+        not-found key rot MalEnv/data @ get
+    endif ;;
+  extend pr-buf { env }
+    env MalEnv/data @ pr-buf
+    a-space s" outer: " str-append
+    env MalEnv/outer @ ?dup 0= if
+        s" <none>" str-append
+    else
+        pr-buf
+    endif ;;
+drop

forth/misc-tests.fs

@@ -2,7 +2,7 @@ require printer.fs
 
 \ === basic testing util === /
 : test=
-  2dup = if
+  2dup m= if
     2drop
   else
     cr ." assert failed on line " sourceline# .
@@ -52,20 +52,38 @@ mal-nil
 23 MalInt. mal-nil conj conj conj
 pr-str s" (nil (20 (42) 10) 23)" str= -1 test=
 
+\ MalArray tests
+
+here 1 MalInt. , 2 MalInt. , 3 MalInt. , here>MalArray
+4 MalInt. swap conj
+5 MalInt. swap conj
+pr-str s" (5 4 1 2 3)" str= -1 test=
+
 \ map tests
 
-s" one" MalString. s" one" MalString. mal= -1 test=
+s" one" MalString. s" one" MalString. test=
-s" one" MalString. s" x" MalString. mal= 0 test=
+s" one" MalString. s" x" MalString. m= 0 test=
+
+MalMap/Empty
+1000 MalInt. 1100 rot assoc
+2000 MalInt. 2100 rot assoc
+3000 MalInt. 3100 rot assoc
+
+dup 99 2000 MalInt. rot get 2100 test=
+dup 99 4000 MalInt. rot get 99 test=
+drop
 
 MalMap/Empty
 s" one" MalString. s" first" MalString. rot assoc
 s" two" MalString. s" second" MalString. rot assoc
 s" three" MalString. s" third" MalString. rot assoc
 
-dup 99 s" two" MalString. rot get s" second" MalString. mal= -1 test=
+dup 99 s" two" MalString. rot get s" second" MalString. test=
 dup 99 s" none" MalString. rot get 99 test=
 drop
 
+99 MalInt. 10 MalInt. MalMap/Empty get 99 MalInt. test=
+
 \ eval tests
 
 require step2_eval.fs
@@ -74,8 +92,6 @@ mal-nil
     1 MalInt. swap conj
     2 MalInt. swap conj
     3 MalInt. swap conj
-~~
 mal-eval
-~~
 
 bye

forth/printer.fs

@@ -149,6 +149,11 @@ MalFn
     drop s" #<fn>" str-append ;;
 drop
 
+SpecialOp
+  extend pr-buf
+    drop s" #<op>" str-append ;;
+drop
+
 MalSymbol
   extend pr-buf
     unpack-sym str-append ;;

forth/reader.fs

@@ -135,9 +135,10 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     ;
 
 : read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list )
-    MalSymbol. { sym } ( buf-addr buf-len char )
+    here { old-here }
-    read-form mal-nil conj ( buf-addr buf-len char mal-list )
+    MalSymbol. , ( buf-addr buf-len char )
-    sym swap conj ;
+    read-form , ( buf-addr buf-len char )
+    old-here here>MalArray ;
 
 : read-form2 ( str-addr str-len char -- str-addr str-len char mal-obj )
     begin
@@ -145,7 +146,7 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
         dup mal-digit? if read-int else
         dup [char] ( = if [char] ) read-array else
         dup [char] [ = if [char] ] read-array MalVector new tuck MalVector/list ! else
-        dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else
+        dup [char] { = if [char] } read-array MalMap new tuck MalMap/list ! else
         dup [char] " = if read-string-literal else
         dup [char] ; = if read-comment else
         dup [char] : = if drop adv-str read-symbol-str MalKeyword. else

forth/step2_eval.fs

@@ -15,9 +15,23 @@ value repl-env
 
 def-protocol-method mal-eval ( env ast -- val )
 def-protocol-method mal-eval-ast ( env ast -- val )
+def-protocol-method invoke ( argv argc mal-fn -- ... )
 
 MalDefault extend mal-eval nip ;; drop
 
+MalKeyword
+  extend invoke { argv argc kw -- val }
+    argc 1 > if argv cell+ @ else mal-nil endif \ not-found
+    kw \ key
+    argv @ \ map
+    get ;;
+drop
+
+MalFn
+  extend invoke ( ... mal-fn -- ... )
+    MalFn/xt @ execute ;;
+drop
+
 MalSymbol
   extend mal-eval { env sym -- val }
     0 sym env get

forth/step3_env.fs

@@ -0,0 +1,160 @@
+require reader.fs
+require printer.fs
+require env.fs
+
+: args-as-native { argv argc -- entry*argc... }
+    argc 0 ?do
+        argv i cells + @ as-native
+    loop ;
+
+0 MalEnv. constant repl-env
+s" +" MalSymbol.  :noname args-as-native + MalInt. ; MalFn.  repl-env env/set
+s" -" MalSymbol.  :noname args-as-native - MalInt. ; MalFn.  repl-env env/set
+s" *" MalSymbol.  :noname args-as-native * MalInt. ; MalFn.  repl-env env/set
+s" /" MalSymbol.  :noname args-as-native / MalInt. ; MalFn.  repl-env env/set
+
+def-protocol-method mal-eval ( env ast -- val )
+def-protocol-method mal-eval-ast ( env ast -- val )
+def-protocol-method invoke+ ( env arty -- ... )
+def-protocol-method invoke ( argv argc mal-fn -- ... )
+
+MalDefault extend mal-eval nip ;; drop
+
+MalKeyword
+  extend invoke { argv argc kw -- val }
+    argc 1 > if argv cell+ @ else mal-nil endif \ not-found
+    kw \ key
+    argv @ \ map
+    get ;;
+drop
+
+MalFn
+  extend invoke ( ... mal-fn -- ... )
+    MalFn/xt @ execute ;;
+
+  extend invoke+ { env ary this -- ary }
+    \ Pass args on dictionary stack (!)
+    \ TODO: consider allocate and free of a real MalArray instead
+    \ Normal list, evaluate and invoke
+    here { val-start }
+    ary MalArray/start @ { expr-start }
+    ary MalArray/count @ 1 ?do
+        env expr-start i cells + @ mal-eval ,
+    loop
+    val-start  here val-start - cell /  this  ( argv argc MalFn )
+    invoke
+    val-start here - allot ;;
+drop
+
+SpecialOp
+  extend invoke+ ( env ary this -- ary )
+    SpecialOp/xt @ execute ;;
+drop
+
+s" quote" MalSymbol. :noname ( env ary -- form )
+    nip MalArray/start @ cell+ @
+; SpecialOp. repl-env env/set
+
+s" def!" MalSymbol. :noname { env ary -- }
+    ary MalArray/start @ cell+ { arg0 }
+    arg0 @ ( key )
+    env arg0 cell+ @ mal-eval dup { val } ( key val )
+    env env/set
+    val
+; SpecialOp. repl-env env/set
+
+s" let*" MalSymbol. :noname { old-env ary -- }
+    old-env MalEnv. { env }
+    ary MalArray/start @ cell+ dup { arg0 }
+    @ to-array
+    dup MalArray/start @ { bindings-start } ( ary )
+    MalArray/count @ 0 +do
+        bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+        env swap mal-eval
+        env env/set
+    2 +loop
+    env arg0 cell+ @ mal-eval
+    \ TODO: dec refcount of env
+; SpecialOp. repl-env env/set
+
+MalSymbol
+  extend mal-eval { env sym -- val }
+    0 sym env get
+    dup 0= if
+        drop
+        ." Symbol '"
+        sym as-native safe-type
+        ." ' not found." cr
+        1 throw
+    endif ;;
+drop
+
+MalArray
+  extend mal-eval { env ary -- val }
+    env ary MalArray/start @ @ mal-eval
+    env ary rot invoke+ ;;
+
+  extend mal-eval-ast { env ary -- ary }
+    here
+    ary MalArray/start @ { expr-start }
+    ary MalArray/count @ 0 ?do
+        env expr-start i cells + @ mal-eval ,
+    loop
+    here>MalArray ;;
+drop
+
+MalList
+  extend mal-eval-ast { env list -- ary }
+    here
+    list
+    begin ( list )
+        dup mal-nil <>
+    while
+        env over MalList/car @ mal-eval ,
+        MalList/cdr @
+    repeat
+    drop here>MalArray ;;
+drop
+
+MalVector
+  extend mal-eval ( env vector -- vector )
+    MalVector/list @ mal-eval-ast
+    MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+  extend mal-eval ( env map -- map )
+    MalMap/list @ mal-eval-ast
+    MalMap new swap over MalMap/list ! ;;
+drop
+
+: read read-str ;
+: eval ( env obj ) mal-eval ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
+
+: rep ( str -- val )
+    read
+    repl-env swap eval
+    print ;
+
+create buff 128 allot
+
+: read-lines
+    begin
+      ." user> "
+      42042042042
+      buff 128 stdin read-line throw
+    while
+      buff swap
+      ['] rep
+      execute safe-type
+      \ catch 0= if safe-type else ." Caught error" endif
+      cr
+      42042042042 <> if ." --stack leak--" cr endif
+    repeat ;
+
+read-lines
+cr
+bye

forth/types.fs

@@ -200,6 +200,20 @@ end-extend
 
 \ === Mal types and protocols === /
 
+def-protocol-method conj ( obj this -- this )
+def-protocol-method assoc ( k v this -- this )
+def-protocol-method get ( not-found k this -- value )
+def-protocol-method mal= ( a b -- bool )
+def-protocol-method as-native ( obj --  )
+def-protocol-method to-array ( obj -- mal-array )
+
+: m= ( a b -- bool )
+    2dup = if
+        2drop -1
+    else
+        mal=
+    endif ;
+
 MalType%
   cell% field MalList/car
   cell% field MalList/cdr
@@ -225,48 +239,63 @@ deftype MalArray
     0 bytes - allot \ pop array contents from dictionary stack
     ;
 
-def-protocol-method conj ( obj this -- this )
+MalArray
-def-protocol-method assoc ( k v this -- this )
+  extend to-array ;;
-def-protocol-method get ( not-found k this -- value )
+  extend conj { elem old-ary -- ary }
-def-protocol-method mal= ( a b -- bool )
+    old-ary MalArray/count @ 1+ { new-count }
-def-protocol-method as-native ( obj --  )
+    new-count cells allocate throw { new-start }
-def-protocol-method invoke ( argv argc mal-fn -- ... )
+    elem new-start !
+    new-count 1 > if
+      old-ary MalArray/start @   new-start cell+   new-count 1- cells  cmove
+    endif
+
+    MalArray new
+    new-count over MalArray/count !
+    new-start over MalArray/start ! ;;
+drop
+
+MalArray new 0 over MalArray/count ! constant MalArray/Empty
 
 MalType%
   cell% field MalVector/list
 deftype MalVector
 
+MalVector
+  extend to-array
+    MalVector/list @ to-array ;;
+drop
+
 MalType%
   cell% field MalMap/list
 deftype MalMap
 
-MalMap new mal-nil over MalMap/list ! constant MalMap/Empty
+MalMap new MalArray/Empty over MalMap/list ! constant MalMap/Empty
 
 MalMap
   extend conj ( kv map -- map )
     MalMap/list @ \ get list
-    over MalList/cdr @ MalList/car @ conj \ add value
+    over MalArray/start @ cell+ @ swap conj \ add value
-    swap MalList/car @ conj \ add key
+    swap MalArray/start @ @ swap conj \ add key
-    MalMap new MalMap/list ! \ put back in map
+    MalMap new dup -rot MalMap/list ! \ put back in map
     ;;
   extend assoc ( k v map -- map )
     MalMap/list @ \ get list
-    conj conj
+    conj conj 
     MalMap new dup -rot MalMap/list ! \ put back in map
     ;;
-  extend get ( not-found k map -- value )
+  extend get { not-found k map -- value }
-    -rot { not-found k }
+    map MalMap/list @
-    MalMap/list @ \ get list
+    dup MalArray/start @ { start }
+    MalArray/count @ { count }
+    0
     begin
-        dup MalList/cdr @
+        dup count >= if
-        swap MalList/car @ k mal= if
+            drop not-found -1
-            MalList/car @ -1 \ found it
         else
-            MalList/cdr @
+            start over cells + @ k m= if
-            dup mal-nil = if
+                start swap cells + cell+ @ -1 \ found it ( value -1 )
-                not-found -1
             else
-                0
+                2 + 0
             endif
         endif
     until ;;
@@ -297,6 +326,13 @@ deftype MalInt
     MalInt new dup MalInt/int int swap ! ;
 
 MalInt
+  extend mal= ( other this -- bool )
+    over mal-type @ MalInt = if
+        MalInt/int @ swap MalInt/int @ =
+    else
+        2drop 0
+    endif ;;
+
   extend as-native ( mal-int -- int )
     MalInt/int @ ;;
 drop
@@ -345,11 +381,6 @@ MalKeyword
         2drop 0
     endif ;;
   ' as-native ' unpack-keyword extend-method*
-  extend invoke { argv argc kw -- val }
-    argc 1 > if argv cell+ @ else mal-nil endif \ not-found
-    kw \ key
-    argv @ \ map
-    get ;;
 drop
 
 : MalKeyword. { str-addr str-len -- mal-keyword }
@@ -396,8 +427,14 @@ deftype MalFn
     mal-fn ;
 
 MalFn
-  extend invoke ( ... mal-fn -- ... )
-    MalFn/xt @ execute ;;
   extend as-native
     MalFn/xt @ ;;
 drop
+
+
+MalType%
+  cell% field SpecialOp/xt
+deftype SpecialOp
+
+: SpecialOp.
+    SpecialOp new swap over SpecialOp/xt ! ;