forth: Add defspecial for Mal special ops

2 files changed, 27 insertions, 15 deletions

diff --git a/forth/step3_env.fs b/forth/step3_env.fs
index f609858..c15f52b 100644
--- a/forth/step3_env.fs
+++ b/forth/step3_env.fs
@@ -54,19 +54,26 @@ SpecialOp
     SpecialOp/xt @ execute ;;
 drop
 
-s" quote" MalSymbol. :noname ( env list -- form )
-    nip MalList/start @ cell+ @
-; SpecialOp. repl-env env/set
+: install-special ( symbol xt )
+    SpecialOp. repl-env env/set ;
 
-s" def!" MalSymbol. :noname { env list -- }
+: defspecial
+    parse-allot-name MalSymbol.
+    ['] install-special
+    :noname
+    ;
+
+defspecial quote ( env list -- form )
+    nip MalList/start @ cell+ @ ;;
+
+defspecial def! { env list -- }
     list MalList/start @ cell+ { arg0 }
     arg0 @ ( key )
     env arg0 cell+ @ mal-eval dup { val } ( key val )
     env env/set
-    val
-; SpecialOp. repl-env env/set
+    val ;;
 
-s" let*" MalSymbol. :noname { old-env list -- }
+defspecial let* { old-env list -- }
     old-env MalEnv. { env }
     list MalList/start @ cell+ dup { arg0 }
     @ to-list
@@ -78,7 +85,7 @@ s" let*" MalSymbol. :noname { old-env list -- }
     2 +loop
     env arg0 cell+ @ mal-eval
     \ TODO: dec refcount of env
-; SpecialOp. repl-env env/set
+    ;;
 
 MalSymbol
   extend mal-eval { env sym -- val }
diff --git a/forth/types.fs b/forth/types.fs
index 305ff31..a8dd2da 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -84,11 +84,15 @@ end-struct MalTypeType%
   dup MalTypeType-name-len    0   swap !   ( MalTypeType )
   ;
 
+\ parse-name uses temporary space, so copy into dictionary stack:
+: parse-allot-name { -- new-str-addr str-len }
+    parse-name { str-addr str-len }
+    here { new-str-addr } str-len allot
+    str-addr new-str-addr str-len cmove
+    new-str-addr str-len ;
+
 : deftype ( struct-align struct-len R:type-name -- )
-    parse-name { orig-name-addr name-len }
-    \ parse-name uses temporary space, so copy into dictionary stack:
-    here { name-addr } name-len allot
-    orig-name-addr name-addr name-len cmove
+    parse-allot-name { name-addr name-len }
 
     \ allot and initialize type structure
     deftype* { mt }
@@ -183,14 +187,15 @@ MalNil new constant mal-nil
   does> ( ??? obj xt-ref -- ??? )
     @ execute-method ;
 
-: extend ( type -- type pxt <noname...>)
+: extend ( type -- type pxt install-xt <noname...>)
     parse-name find-name name>int ( type pxt )
+    ['] extend-method*
     :noname
     ;
 
 : ;; ( type pxt <noname...> -- type )
-    [compile] ; ( type pxt ixt )
-    extend-method*
+    [compile] ; ( type pxt install-xt ixt )
+    swap execute
     ; immediate
 
 (