forth: Split types for user fns vs native fns

6 files changed, 72 insertions, 60 deletions

diff --git a/forth/core.fs b/forth/core.fs
index 6e8ccfb..16105ad 100644
--- a/forth/core.fs
+++ b/forth/core.fs
@@ -2,14 +2,14 @@ require env.fs
 
 0 MalEnv. constant core
 
-: args-as-native drop { argv argc -- entry*argc... }
+: args-as-native { 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 ;
+    swap MalNativeFn. core env/set ;
 
 :noname args-as-native + MalInt. ; defcore +
 :noname args-as-native - MalInt. ; defcore -
@@ -20,7 +20,7 @@ require env.fs
 :noname args-as-native <= mal-bool ; defcore <=
 :noname args-as-native >= mal-bool ; defcore >=
 
-:noname drop { argv argc }
+:noname { argv argc }
     MalList new { list }
     argc cells allocate throw { start }
     argv  start  argc cells  cmove
@@ -29,8 +29,8 @@ require env.fs
     list
 ; defcore list
 
-:noname 2drop @ mal-type @ MalList = mal-bool ; defcore list?
-:noname 2drop @ empty? ; defcore empty?
-:noname 2drop @ mal-count ; defcore count
+:noname drop @ mal-type @ MalList = mal-bool ; defcore list?
+:noname drop @ empty? ; defcore empty?
+:noname drop @ mal-count ; defcore count
 
-:noname 2drop dup @ swap cell+ @ swap m= mal-bool ; defcore =
+:noname drop dup @ swap cell+ @ swap m= mal-bool ; defcore =
diff --git a/forth/printer.fs b/forth/printer.fs
index 39ddb8e..0474944 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -62,7 +62,9 @@ def-protocol-method pr-pairs-buf ( str-addr str-len this -- str-addr str-len )
 MalDefault
   extend pr-buf
     { this }
-    s" #<MalObject" str-append a-space
+    s" #<" str-append
+    this mal-type @ type-name str-append
+    a-space
     this int>str str-append
     s" >" str-append ;;
 drop
@@ -117,16 +119,6 @@ MalInt
     MalInt/int @ int>str str-append ;;
 drop
 
-MalFn
-  extend pr-buf
-    drop s" #<fn>" str-append ;;
-drop
-
-SpecialOp
-  extend pr-buf
-    drop s" #<op>" str-append ;;
-drop
-
 MalSymbol
   extend pr-buf
     unpack-sym str-append ;;
diff --git a/forth/step2_eval.fs b/forth/step2_eval.fs
index 6a9af72..4963111 100644
--- a/forth/step2_eval.fs
+++ b/forth/step2_eval.fs
@@ -7,10 +7,10 @@ require printer.fs
     loop ;
 
 MalMap/Empty
-    s" +" MalSymbol. :noname args-as-native + MalInt. ; MalFn. rot assoc
-    s" -" MalSymbol. :noname args-as-native - MalInt. ; MalFn. rot assoc
-    s" *" MalSymbol. :noname args-as-native * MalInt. ; MalFn. rot assoc
-    s" /" MalSymbol. :noname args-as-native / MalInt. ; MalFn. rot assoc
+    s" +" MalSymbol. :noname args-as-native + MalInt. ; MalNativeFn. rot assoc
+    s" -" MalSymbol. :noname args-as-native - MalInt. ; MalNativeFn. rot assoc
+    s" *" MalSymbol. :noname args-as-native * MalInt. ; MalNativeFn. rot assoc
+    s" /" MalSymbol. :noname args-as-native / MalInt. ; MalNativeFn. rot assoc
 value repl-env
 
 def-protocol-method mal-eval ( env ast -- val )
@@ -27,9 +27,9 @@ MalKeyword
     get ;;
 drop
 
-MalFn
+MalNativeFn
   extend invoke ( ... mal-fn -- ... )
-    MalFn/xt @ execute ;;
+    MalNativeFn/xt @ execute ;;
 drop
 
 MalSymbol
@@ -53,7 +53,7 @@ MalList
     list MalList/count @ 0 ?do
         env expr-start i cells + @ mal-eval ,
     loop
-    val-start cell+  here val-start - cell / 1-  val-start @  ( argv argc MalFn )
+    val-start cell+  here val-start - cell / 1-  val-start @  ( argv argc MalNativeFn )
     invoke
     val-start here - allot ;;
   extend mal-eval-ast { env list -- list }
diff --git a/forth/step3_env.fs b/forth/step3_env.fs
index c15f52b..7dc9d7e 100644
--- a/forth/step3_env.fs
+++ b/forth/step3_env.fs
@@ -8,10 +8,10 @@ require env.fs
     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
+s" +" MalSymbol.  :noname args-as-native + MalInt. ; MalNativeFn.  repl-env env/set
+s" -" MalSymbol.  :noname args-as-native - MalInt. ; MalNativeFn.  repl-env env/set
+s" *" MalSymbol.  :noname args-as-native * MalInt. ; MalNativeFn.  repl-env env/set
+s" /" MalSymbol.  :noname args-as-native / MalInt. ; MalNativeFn.  repl-env env/set
 
 \ Fully evalutate any Mal object:
 def-protocol-method mal-eval ( env ast -- val )
@@ -34,7 +34,7 @@ MalKeyword
     endif ;;
 drop
 
-MalFn
+MalNativeFn
   extend invoke { env list this -- list }
     \ Pass args on dictionary stack (!)
     \ TODO: consider allocate and free of a real MalList instead
@@ -44,8 +44,8 @@ MalFn
     list MalList/count @ 1 ?do
         env expr-start i cells + @ mal-eval ,
     loop
-    val-start  here val-start - cell /  this  ( argv argc MalFn )
-    MalFn/xt @ execute
+    val-start  here val-start - cell /  this  ( argv argc MalNativeFn )
+    MalNativeFn/xt @ execute
     val-start here - allot ;;
 drop
 
diff --git a/forth/step4_if_fn_do.fs b/forth/step4_if_fn_do.fs
index 0350d13..b41fe29 100644
--- a/forth/step4_if_fn_do.fs
+++ b/forth/step4_if_fn_do.fs
@@ -25,19 +25,28 @@ MalKeyword
     endif ;;
 drop
 
-MalFn
-  extend invoke { env list this -- list }
+\ eval all but the first item of list, storing in temporary memory
+\ that should be freed with free-eval-rest when done.
+: eval-rest { env list -- mem-token argv argc }
     \ 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
+    list MalList/start @ cell+ { expr-start }
+    list MalList/count @ 1- dup { argc } 0 ?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 ;;
+    val-start  val-start  argc ;
+
+: free-eval-rest ( mem-token/val-start -- )
+    here - allot ;
+
+MalNativeFn
+  extend invoke ( env list this -- list )
+    MalNativeFn/xt @ { xt }
+    eval-rest ( mem-token argv argc )
+    xt execute ( mem-token return-val )
+    swap free-eval-rest ;;
 drop
 
 SpecialOp
@@ -107,8 +116,11 @@ defspecial if { env list -- val }
         env arg0 cell+ @ mal-eval
     endif ;;
 
-: user-fn { argv argc mal-fn -- return-val }
-    mal-fn MalFn/formal-args @ dup { f-args-list }
+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
@@ -116,7 +128,7 @@ defspecial if { env list -- val }
         1 throw
     endif
 
-    mal-fn MalFn/env @ MalEnv. { env }
+    mal-fn MalUserFn/env @ MalEnv. { env }
 
     f-args-list MalList/start @ { f-args }
     argc 0 ?do
@@ -125,14 +137,16 @@ defspecial if { env list -- val }
         env env/set
     loop
 
-    env   mal-fn MalFn/body @   mal-eval ;
+    env   mal-fn MalUserFn/body @   mal-eval
+
+    mem-token free-eval-rest ;;
 
 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 ! ;;
+    MalUserFn new
+    env over MalUserFn/env !
+    arg0 @ to-list over MalUserFn/formal-args !
+    arg0 cell+ @ over MalUserFn/body ! ;;
 
 MalSymbol
   extend mal-eval { env sym -- val }
diff --git a/forth/types.fs b/forth/types.fs
index 5eb546f..7675a5e 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -460,26 +460,32 @@ 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 }
-    MalFn new { mal-fn }
-    xt mal-fn MalFn/xt !
-    MalMap/Empty mal-fn MalFn/meta  !
+  cell% field MalNativeFn/xt
+  cell% field MalNativeFn/meta
+deftype MalNativeFn
+
+: MalNativeFn. { xt -- mal-fn }
+    MalNativeFn new { mal-fn }
+    xt mal-fn MalNativeFn/xt !
+    MalMap/Empty mal-fn MalNativeFn/meta  !
     mal-fn ;
 
-MalFn
+MalNativeFn
   extend as-native
-    MalFn/xt @ ;;
+    MalNativeFn/xt @ ;;
 drop
 
 
 MalType%
+  cell% field MalUserFn/meta
+  cell% field MalUserFn/env
+  cell% field MalUserFn/formal-args
+  cell% field MalUserFn/var-arg
+  cell% field MalUserFn/body
+deftype MalUserFn
+
+
+MalType%
   cell% field SpecialOp/xt
 deftype SpecialOp