forth: Add support for & var-args

3 files changed, 82 insertions, 30 deletions

diff --git a/forth/core.fs b/forth/core.fs
index 16105ad..6dd4ec4 100644
--- a/forth/core.fs
+++ b/forth/core.fs
@@ -7,30 +7,61 @@ require env.fs
         argv i cells + @ as-native
     loop ;
 
-: defcore ( xt )
-    parse-allot-name MalSymbol. ( xt sym )
-    swap MalNativeFn. 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 { argv argc }
+: defcore* ( sym xt )
+    MalNativeFn. core env/set ;
+
+: defcore
+    parse-allot-name MalSymbol. ( xt )
+    ['] defcore* :noname ;
+
+defcore +  args-as-native +  MalInt. ;;
+defcore -  args-as-native -  MalInt. ;;
+defcore *  args-as-native *  MalInt. ;;
+defcore /  args-as-native /  MalInt. ;;
+defcore <  args-as-native <  mal-bool ;;
+defcore >  args-as-native >  mal-bool ;;
+defcore <= args-as-native <= mal-bool ;;
+defcore >= args-as-native >= mal-bool ;;
+
+defcore list { 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
+    list ;;
+
+defcore list? drop @ mal-type @ MalList = mal-bool ;;
+defcore empty? drop @ empty? ;;
+defcore count drop @ mal-count ;;
+
+defcore = drop dup @ swap cell+ @ swap m= mal-bool ;;
+defcore not
+    drop @
+    dup mal-nil = if
+        drop mal-true
+    else
+        mal-false = if
+            mal-true
+        else
+            mal-false
+        endif
+    endif ;;
+
+: pr-str-multi ( argv argc )
+    ?dup 0= if drop s" "
+    else
+        { argv argc }
+        new-str
+        argv @ pr-buf
+        argc 1 ?do
+            a-space
+            argv i cells + @ pr-buf
+        loop
+    endif ;
 
-:noname drop @ mal-type @ MalList = mal-bool ; defcore list?
-:noname drop @ empty? ; defcore empty?
-:noname drop @ mal-count ; defcore count
+defcore prn pr-str-multi type cr mal-nil ;;
+defcore pr-str pr-str-multi MalString. ;;
 
-:noname drop dup @ swap cell+ @ swap m= mal-bool ; defcore =
+defcore str drop @ pr-str MalString. ;;
+defcore println pr-str-multi 10 str-append-char MalString. ;;
diff --git a/forth/step4_if_fn_do.fs b/forth/step4_if_fn_do.fs
index b41fe29..46163bc 100644
--- a/forth/step4_if_fn_do.fs
+++ b/forth/step4_if_fn_do.fs
@@ -116,23 +116,40 @@ defspecial if { env list -- val }
         env arg0 cell+ @ mal-eval
     endif ;;
 
+s" &" MalSymbol. constant &-sym
+
 MalUserFn
   extend invoke { call-env list mal-fn -- list }
     call-env list eval-rest { mem-token argv argc }
 
-    mal-fn MalUserFn/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 MalUserFn/formal-args @ { f-args-list }
+    \ \ This isn't correct for fns with & in their f-args-list:
+    \ f-args-list MalList/count @ argc 2dup = if
+    \     2drop
+    \ else
+    \     ." Argument mismatch on user fn. Got " . ." but expected " . cr
+    \     1 throw
+    \ endif
 
     mal-fn MalUserFn/env @ MalEnv. { env }
 
     f-args-list MalList/start @ { f-args }
+    f-args-list MalList/count @ ?dup 0= if else
+        \ pass nil for last arg, unless overridden below
+        1- cells f-args + @ mal-nil env env/set
+    endif
     argc 0 ?do
         f-args i cells + @
+        dup &-sym m= if
+            drop
+            f-args i 1+ cells + @ ( more-args-symbol )
+            MalList new ( sym more-args )
+            argc i - dup { c } over MalList/count !
+            c cells allocate throw dup { start } over MalList/start !
+            argv i cells +  start  c cells  cmove
+            env env/set
+            leave
+        endif
         argv i cells + @
         env env/set
     loop
diff --git a/forth/types.fs b/forth/types.fs
index 7675a5e..51f04ed 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -125,6 +125,8 @@ MalType% deftype MalFalse MalFalse new constant mal-false
 
 \ === protocol methods === /
 
+0 constant trace
+
 \ Used by protocol methods to find the appropriate implementation of
 \ themselves for the given object, and then execute that implementation.
 : execute-method { obj pxt -- }
@@ -153,10 +155,10 @@ MalType% deftype MalFalse MalFalse new constant mal-false
       ." '"
       1 throw
   endif
+  trace if ." Calling '" pxt >name name>string type ." ' on " obj mal-type @ type-name type cr endif
 
   cells swap MalTypeType-method-vals @ + @ ( xt )
-  obj swap execute
-  ;
+  obj swap execute ;
 
 \ Extend a type with a protocol method. This mutates the MalTypeType
 \ object that represents the MalType being extended.
@@ -313,13 +315,15 @@ deftype MalVector
 
 MalVector
   extend to-list
-    MalVector/list @ to-list ;;
+    MalVector/list @ ;;
   extend empty?
     MalVector/list @
     MalList/count @ 0= mal-bool ;;
   extend mal-count
     MalVector/list @
     MalList/count @ MalInt. ;;
+  extend mal=
+    MalVector/list @ swap m= ;;
 drop
 
 MalType%