forth: Add step 4, but not varargs

5 files changed, 327 insertions, 34 deletions

diff --git a/forth/core.fs b/forth/core.fs
new file mode 100644
index 0000000..6e8ccfb
--- /dev/null
+++ b/forth/core.fs
@@ -0,0 +1,36 @@
+require env.fs
+
+0 MalEnv. constant core
+
+: args-as-native drop { argv argc -- entry*argc... }
+    argc 0 ?do
+        argv i cells + @ as-native
+    loop ;
+
+: defcore ( xt )
+    parse-allot-name MalSymbol. ( xt sym )
+    swap MalFn. core env/set ;
+
+:noname args-as-native + MalInt. ; defcore +
+:noname args-as-native - MalInt. ; defcore -
+:noname args-as-native * MalInt. ; defcore *
+:noname args-as-native / MalInt. ; defcore /
+:noname args-as-native < mal-bool ; defcore <
+:noname args-as-native > mal-bool ; defcore >
+:noname args-as-native <= mal-bool ; defcore <=
+:noname args-as-native >= mal-bool ; defcore >=
+
+:noname drop { argv argc }
+    MalList new { list }
+    argc cells allocate throw { start }
+    argv  start  argc cells  cmove
+    argc  list MalList/count !
+    start list MalList/start !
+    list
+; defcore list
+
+:noname 2drop @ mal-type @ MalList = mal-bool ; defcore list?
+:noname 2drop @ empty? ; defcore empty?
+:noname 2drop @ mal-count ; defcore count
+
+:noname 2drop dup @ swap cell+ @ swap m= mal-bool ; defcore =
diff --git a/forth/printer.fs b/forth/printer.fs
index 78ac197..39ddb8e 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -67,10 +67,9 @@ MalDefault
     s" >" str-append ;;
 drop
 
-MalNil
-  extend pr-buf
-    drop s" nil" str-append ;;
-drop
+MalNil   extend pr-buf drop s" nil"   str-append ;; drop
+MalTrue  extend pr-buf drop s" true"  str-append ;; drop
+MalFalse extend pr-buf drop s" false" str-append ;; drop
 
 MalList
   extend pr-buf
@@ -78,12 +77,14 @@ MalList
     rot pr-seq-buf
     s" )" str-append ;;
   extend pr-seq-buf { list }
-    list MalList/start @ { start }
-    start @ pr-buf
-    list MalList/count @ 1 ?do
-        a-space
-        start i cells + @ pr-buf
-    loop ;;
+    list MalList/count @ 0 > if
+        list MalList/start @ { start }
+        start @ pr-buf
+        list MalList/count @ 1 ?do
+            a-space
+            start i cells + @ pr-buf
+        loop
+    endif ;;
   extend pr-pairs-buf { list }
     list MalList/start @ { start }
     start @ pr-buf a-space start cell+ @ pr-buf
diff --git a/forth/reader.fs b/forth/reader.fs
index f65db2c..2ed3446 100644
--- a/forth/reader.fs
+++ b/forth/reader.fs
@@ -141,8 +141,13 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
             obj swap conj
             s" with-meta" MalSymbol. swap conj
         else
-            read-symbol-str MalSymbol.
-        endif endif endif endif endif endif endif endif endif endif endif endif
+            read-symbol-str
+            2dup s" true" str= if 2drop mal-true
+            else 2dup s" false" str= if 2drop mal-false
+            else 2dup s" nil" str= if 2drop mal-nil
+            else
+              MalSymbol.
+        endif endif endif endif endif endif endif endif endif endif endif endif endif endif endif
         dup skip-elem =
     while drop repeat ;
 ' read-form2 is read-form
diff --git a/forth/step4_if_fn_do.fs b/forth/step4_if_fn_do.fs
new file mode 100644
index 0000000..0350d13
--- /dev/null
+++ b/forth/step4_if_fn_do.fs
@@ -0,0 +1,204 @@
+require reader.fs
+require printer.fs
+require core.fs
+
+core MalEnv. constant repl-env
+
+\ Fully evalutate any Mal object:
+def-protocol-method mal-eval ( env ast -- val )
+
+\ Invoke an object, given whole env and unevaluated argument forms:
+def-protocol-method invoke ( argv argc mal-fn -- ... )
+
+MalDefault extend mal-eval nip ;; drop
+
+MalKeyword
+  extend invoke { env list kw -- val }
+    0   kw   env list MalList/start @ cell+ @ mal-eval   get
+    ?dup 0= if
+        \ compute not-found value
+        list MalList/count @ 1 > if
+            env  list MalList/start @ 2 cells + @  mal-eval
+        else
+            mal-nil
+        endif
+    endif ;;
+drop
+
+MalFn
+  extend invoke { env list this -- list }
+    \ Pass args on dictionary stack (!)
+    \ TODO: consider allocate and free of a real MalList instead
+    \ Normal list, evaluate and invoke
+    here { val-start }
+    list MalList/start @ { expr-start }
+    list MalList/count @ 1 ?do
+        env expr-start i cells + @ mal-eval ,
+    loop
+    val-start  here val-start - cell /  this  ( argv argc MalFn )
+    dup MalFn/xt @ execute
+    val-start here - allot ;;
+drop
+
+SpecialOp
+  extend invoke ( env list this -- list )
+    SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+    SpecialOp. repl-env env/set ;
+
+: defspecial
+    parse-allot-name MalSymbol.
+    ['] install-special
+    :noname
+    ;
+
+defspecial quote ( env list -- form )
+    nip MalList/start @ cell+ @ ;;
+
+defspecial def! { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    arg0 @ ( key )
+    env arg0 cell+ @ mal-eval dup { val } ( key val )
+    env env/set
+    val ;;
+
+defspecial let* { old-env list -- val }
+    old-env MalEnv. { env }
+    list MalList/start @ cell+ dup { arg0 }
+    @ to-list
+    dup MalList/start @ { bindings-start } ( list )
+    MalList/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
+    ;;
+
+defspecial do { env list -- val }
+    list MalList/start @
+    0
+    list MalList/count @ 1 ?do
+        drop
+        dup i cells + @ env swap mal-eval
+    loop
+    nip ;;
+
+defspecial if { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    env arg0 @ mal-eval ( test-val )
+    dup mal-false = if
+        drop -1
+    else
+        mal-nil =
+    endif
+    if
+        \ branch to false
+        list MalList/count @ 3 > if
+            env arg0 cell+ cell+ @ mal-eval
+        else
+            mal-nil
+        endif
+    else
+        \ branch to true
+        env arg0 cell+ @ mal-eval
+    endif ;;
+
+: user-fn { argv argc mal-fn -- return-val }
+    mal-fn MalFn/formal-args @ dup { f-args-list }
+    MalList/count @ argc 2dup = if
+        2drop
+    else
+        ." Argument mismatch on user fn. Got " . ." but expected " . cr
+        1 throw
+    endif
+
+    mal-fn MalFn/env @ MalEnv. { env }
+
+    f-args-list MalList/start @ { f-args }
+    argc 0 ?do
+        f-args i cells + @
+        argv i cells + @
+        env env/set
+    loop
+
+    env   mal-fn MalFn/body @   mal-eval ;
+
+defspecial fn* { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    ['] user-fn MalFn.
+    env over MalFn/env !
+    arg0 @ to-list over MalFn/formal-args !
+    arg0 cell+ @ over MalFn/body ! ;;
+
+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
+
+: mal-eval-ast { env list -- list }
+    here
+    list MalList/start @ { expr-start }
+    list MalList/count @ 0 ?do
+        env expr-start i cells + @ mal-eval ,
+    loop
+    here>MalList ;
+
+MalList
+  extend mal-eval { env list -- val }
+    env list MalList/start @ @ mal-eval
+    env list rot invoke ;;
+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> "
+      77777777777
+      buff 128 stdin read-line throw
+    while
+      buff swap
+      ['] rep
+      execute safe-type
+      \ catch 0= if safe-type else ." Caught error" endif
+      cr
+      77777777777 <> if ." --stack leak--" cr endif
+    repeat ;
+
+read-lines
+cr
+bye
diff --git a/forth/types.fs b/forth/types.fs
index a8dd2da..5eb546f 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -109,8 +109,12 @@ end-struct MalTypeType%
 MalType% deftype MalDefault
 
 \ nil type and instance to support extending protocols to it
-MalType% deftype MalNil
-MalNil new constant mal-nil
+MalType% deftype MalNil   MalNil   new constant mal-nil
+MalType% deftype MalTrue  MalTrue  new constant mal-true
+MalType% deftype MalFalse MalFalse new constant mal-false
+
+: mal-bool
+    0= if mal-false else mal-true endif ;
 
 : not-object? ( obj -- bool )
     dup 7 and 0 <> if
@@ -219,7 +223,10 @@ 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-list ( obj -- mal-list )
+def-protocol-method empty? ( obj -- mal-bool )
+def-protocol-method mal-count ( obj -- mal-int )
 
 : m= ( a b -- bool )
     2dup = if
@@ -228,6 +235,27 @@ def-protocol-method to-list ( obj -- mal-list )
         mal=
     endif ;
 
+
+MalType%
+  cell% field MalInt/int
+deftype MalInt
+
+: MalInt. { int -- mal-int }
+    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
+
+
 MalType%
   cell% field MalList/count
   cell% field MalList/start
@@ -255,6 +283,26 @@ MalList
     MalList new
     new-count over MalList/count !
     new-start over MalList/start ! ;;
+  extend empty? MalList/count @ 0= mal-bool ;;
+  extend mal-count MalList/count @ MalInt. ;;
+  extend mal=
+    swap to-list dup 0= if
+        nip
+    else
+        2dup MalList/count @ swap MalList/count @ over = if ( list-a list-b count )
+            -rot MalList/start @ swap MalList/start @ { start-b start-a }
+            -1 swap ( return-val count )
+            0 ?do
+                start-a i cells + @
+                start-b i cells + @
+                m= if else
+                    drop 0 leave
+                endif
+            loop
+        else
+            drop 2drop 0
+        endif
+    endif ;;
 drop
 
 MalList new 0 over MalList/count ! constant MalList/Empty
@@ -266,6 +314,12 @@ deftype MalVector
 MalVector
   extend to-list
     MalVector/list @ to-list ;;
+  extend empty?
+    MalVector/list @
+    MalList/count @ 0= mal-bool ;;
+  extend mal-count
+    MalVector/list @
+    MalList/count @ MalInt. ;;
 drop
 
 MalType%
@@ -302,6 +356,12 @@ MalMap
             endif
         endif
     until ;;
+  extend empty?
+    MalMap/list @
+    MalList/count @ 0= mal-bool ;;
+  extend mal-count
+    MalMap/list @
+    MalList/count @ 2 / MalInt. ;;
 drop
 
 \ Examples of extending existing protocol methods to existing type
@@ -309,32 +369,16 @@ MalDefault
   extend conj   ( obj this -- this )
     nip ;;
   extend as-native ;; ( obj -- obj )
+  extend to-list drop 0 ;;
 drop
 
 MalNil
   extend conj ( item nil -- mal-list )
     drop MalList/Empty conj ;;
   extend as-native drop 0 ;;
-drop
-
-
-MalType%
-  cell% field MalInt/int
-deftype MalInt
-
-: MalInt. { int -- mal-int }
-    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 @ ;;
+  extend empty? drop mal-true ;;
+  extend mal-count drop 0 MalInt. ;;
+  extend mal= drop mal-nil = ;;
 drop
 
 MalType%
@@ -418,6 +462,9 @@ drop
 MalType%
   cell% field MalFn/xt
   cell% field MalFn/meta
+  cell% field MalFn/env
+  cell% field MalFn/formal-args
+  cell% field MalFn/body
 deftype MalFn
 
 : MalFn. { xt -- mal-fn }