forth: Add step 7

4 files changed, 333 insertions, 6 deletions

diff --git a/forth/core.fs b/forth/core.fs
index 71f43ca..e601e1d 100644
--- a/forth/core.fs
+++ b/forth/core.fs
@@ -77,3 +77,22 @@ defcore str ( argv argc )
 
 defcore read-string drop @ unpack-str read-str ;;
 defcore slurp drop @ unpack-str slurp-file MalString. ;;
+
+defcore cons ( argv[item,coll] argc )
+    drop dup @ swap cell+ @ ( item coll )
+    to-list conj ;;
+
+defcore concat { lists argc }
+    0   lists argc cells +  lists  +do ( count )
+        i @ to-list MalList/count @ +
+    cell +loop { count }
+    count cells allocate throw { start }
+    start   lists argc cells +  lists  +do ( target )
+        i @ to-list MalList/count @ cells  2dup  i @ to-list MalList/start @  -rot  ( target bytes src target bytes )
+        cmove ( target bytes )
+        + ( new-target )
+    cell +loop
+    drop
+    MalList new
+    start over MalList/start !
+    count over MalList/count ! ;;
diff --git a/forth/reader.fs b/forth/reader.fs
index 6547a79..1daa650 100644
--- a/forth/reader.fs
+++ b/forth/reader.fs
@@ -98,9 +98,15 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     drop adv-str
     old-here here>MalList ;
 
+s" deref"          MalSymbol. constant deref-sym
+s" quote"          MalSymbol. constant quote-sym
+s" quasiquote"     MalSymbol. constant quasiquote-sym
+s" splice-unquote" MalSymbol. constant splice-unquote-sym
+s" unquote"        MalSymbol. constant unquote-sym
+
 : read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list )
     here { old-here }
-    MalSymbol. , ( buf-addr buf-len char )
+    , ( buf-addr buf-len char )
     read-form , ( buf-addr buf-len char )
     old-here here>MalList ;
 
@@ -112,13 +118,13 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else
     dup [char] " = if read-string-literal else
     dup [char] : = if drop adv-str read-symbol-str MalKeyword. else
-    dup [char] @ = if drop adv-str s" deref" read-wrapped else
-    dup [char] ' = if drop adv-str s" quote" read-wrapped else
-    dup [char] ` = if drop adv-str s" quasiquote" read-wrapped else
+    dup [char] @ = if drop adv-str deref-sym read-wrapped else
+    dup [char] ' = if drop adv-str quote-sym read-wrapped else
+    dup [char] ` = if drop adv-str quasiquote-sym read-wrapped else
     dup [char] ~ = if
         drop adv-str
-        dup [char] @ = if drop adv-str s" splice-unquote" read-wrapped
-        else s" unquote" read-wrapped
+        dup [char] @ = if drop adv-str splice-unquote-sym read-wrapped
+        else unquote-sym read-wrapped
         endif
     else
     dup [char] ^ = if
diff --git a/forth/step7_quote.fs b/forth/step7_quote.fs
new file mode 100644
index 0000000..46c2fb2
--- /dev/null
+++ b/forth/step7_quote.fs
@@ -0,0 +1,301 @@
+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 -- ... )
+
+99999999 constant TCO-eval
+
+: read read-str ;
+: eval ( env obj )
+    begin
+        \ ." eval-> " dup pr-str safe-type cr
+        mal-eval
+        dup TCO-eval =
+    while
+        drop
+    repeat ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+  extend invoke { env list kw -- val }
+    0   kw   env list MalList/start @ cell+ @ eval   get
+    ?dup 0= if
+        \ compute not-found value
+        list MalList/count @ 1 > if
+            env  list MalList/start @ 2 cells + @  TCO-eval
+        else
+            mal-nil
+        endif
+    endif ;;
+drop
+
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+    list MalList/start @ cell+ { expr-start }
+    list MalList/count @ 1- { argc }
+    argc cells allocate throw { target }
+    argc 0 ?do
+        env expr-start i cells + @ eval
+        target i cells + !
+    loop
+    target argc ;
+
+MalNativeFn
+  extend invoke ( env list this -- list )
+    MalNativeFn/xt @ { xt }
+    eval-rest ( argv argc )
+    xt execute ( return-val ) ;;
+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
+    ;
+
+: is-pair? ( obj -- bool )
+    empty? mal-false = ;
+
+defspecial quote ( env list -- form )
+    nip MalList/start @ cell+ @ ;;
+
+s" concat" MalSymbol. constant concat-sym
+s" cons" MalSymbol. constant cons-sym
+
+defer quasiquote
+: quasiquote0 { ast -- form }
+    ast is-pair? 0= if
+        here quote-sym , ast , here>MalList
+    else
+        ast to-list MalList/start @ { ast-start }
+        ast-start @ { ast[0] }
+        ast[0] unquote-sym m= if
+            ast-start cell+ @
+        else
+            ast[0] is-pair? if
+                ast[0] to-list MalList/start @ { ast[0]-start }
+                ast[0]-start @ splice-unquote-sym m= if
+                    here
+                    concat-sym ,
+                    ast[0]-start cell+ @ ,
+                    ast to-list MalList/rest quasiquote ,
+                    here>MalList
+                    false
+                else true endif
+            else true endif
+            if
+                here
+                cons-sym ,
+                ast[0] quasiquote ,
+                ast to-list MalList/rest quasiquote ,
+                here>MalList
+            endif
+        endif
+    endif ;
+' quasiquote0 is quasiquote
+
+defspecial quasiquote ( env list )
+    MalList/start @ cell+ @ ( ast )
+    quasiquote TCO-eval ;;
+
+defspecial def! { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    arg0 @ ( key )
+    env arg0 cell+ @ 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 eval
+        env env/set
+    2 +loop
+    env arg0 cell+ @ TCO-eval
+    \ TODO: dec refcount of env
+    ;;
+
+defspecial do { env list -- val }
+    list MalList/start @ { start }
+    list MalList/count @ dup 1- { last } 1 ?do
+        env   start i cells + @
+        i last = if
+            TCO-eval
+        else
+            eval drop
+        endif
+    loop ;;
+
+defspecial if { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    env arg0 @ 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+ @ TCO-eval
+        else
+            mal-nil
+        endif
+    else
+        \ branch to true
+        env arg0 cell+ @ TCO-eval
+    endif ;;
+
+s" &" MalSymbol. constant &-sym
+
+MalUserFn
+  extend invoke { call-env list mal-fn -- list }
+    call-env list eval-rest { argv argc }
+
+    mal-fn MalUserFn/formal-args @ { f-args-list }
+    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
+
+    env   mal-fn MalUserFn/body @   TCO-eval ;;
+drop
+
+defspecial fn* { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    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 }
+    0 sym env get
+    dup 0= if
+        drop
+        ." Symbol '"
+        sym as-native safe-type
+        ." ' not found." cr
+        1 throw
+    endif ;;
+drop
+
+: eval-ast { env list -- list }
+    here
+    list MalList/start @ { expr-start }
+    list MalList/count @ 0 ?do
+        env expr-start i cells + @ eval ,
+    loop
+    here>MalList ;
+
+MalList
+  extend mal-eval { env list -- val }
+    env list MalList/start @ @ eval
+    env list rot invoke ;;
+drop
+
+MalVector
+  extend mal-eval ( env vector -- vector )
+    MalVector/list @ eval-ast
+    MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+  extend mal-eval ( env map -- map )
+    MalMap/list @ eval-ast
+    MalMap new swap over MalMap/list ! ;;
+drop
+
+defcore eval ( argv argc )
+  drop @ repl-env swap eval ;;
+
+: rep ( str-addr str-len -- val )
+    read
+    repl-env swap eval
+    print ;
+
+: mk-args-list ( -- )
+    here
+    begin
+        next-arg 2dup 0 0 d<> while
+            MalString. ,
+    repeat
+    2drop here>MalList ;
+
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: repl ( -- )
+    begin
+      ." user> "
+      stack-leak-detect
+      buff 128 stdin read-line throw
+    while
+      buff swap
+      ['] rep
+      execute type
+      \ catch ?dup 0= if safe-type else ." Caught error " . endif
+      cr
+      stack-leak-detect <> if ." --stack leak--" cr endif
+    repeat ;
+
+: main ( -- )
+    mk-args-list { args-list }
+    args-list MalList/count @ 0= if
+        s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
+        repl
+    else
+        args-list MalList/start @ @ { filename }
+        s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set
+
+        repl-env
+        here s" load-file" MalSymbol. , filename , here>MalList
+        eval print
+    endif ;
+
+main
+cr
+bye
diff --git a/forth/types.fs b/forth/types.fs
index 5b8a211..79965e8 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -380,6 +380,7 @@ MalDefault
     nip ;;
   extend as-native ;; ( obj -- obj )
   extend to-list drop 0 ;;
+  extend empty? drop mal-true ;;
 drop
 
 MalNil