forth: Finish step 9

forth/core.fs

@@ -24,14 +24,16 @@ 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 argc MalList. ;;
-    start list MalList/start !
+
-    list ;;
+defcore vector { argv argc }
+    argc cells allocate throw { start }
+    argv  start  argc cells  cmove
+    start argc MalList.
+    MalVector new swap over MalVector/list ! ;;
 
-defcore list? drop @ mal-type @ MalList = mal-bool ;;
 defcore empty? drop @ empty? ;;
 defcore count drop @ mal-count ;;
 
@@ -83,19 +85,66 @@ defcore cons ( argv[item,coll] argc )
     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 !
+    lists over MalList/start !
-    count over MalList/count ! ;;
+    argc over MalList/count !
+    MalList/concat ;;
+
+defcore conj { argv argc }
+    argv @ ( coll )
+    argc 1 ?do
+        argv i cells + @ swap conj
+    loop ;;
+
+defcore assoc { argv argc }
+    argv @ ( coll )
+    argv argc cells +  argv cell+  +do
+        i @ \ key
+        i cell+ @ \ val
+        rot assoc
+    2 cells +loop ;;
+
+defcore keys ( argv argc )
+    drop @ MalMap/list @
+    dup MalList/start @ swap MalList/count @ { start count }
+    here
+    start count cells +  start  +do
+        i @ ,
+    2 cells +loop
+    here>MalList ;;
+
+defcore vals ( argv argc )
+    drop @ MalMap/list @
+    dup MalList/start @ swap MalList/count @ { start count }
+    here
+    start count cells +  start cell+  +do
+        i @ ,
+    2 cells +loop
+    here>MalList ;;
+
+defcore dissoc { argv argc }
+    argv @ \ coll
+    argv argc cells +  argv cell+  +do
+        i @ swap dissoc
+    cell +loop ;;
+
+defcore hash-map { argv argc }
+    MalMap/Empty
+    argc cells argv +  argv  +do
+        i @  i cell+ @  rot  assoc
+    2 cells +loop ;;
+
+defcore get { argv argc }
+    argc 3 < if mal-nil else argv cell+ cell+ @ endif
+    argv cell+ @ \ key
+    argv @ \ coll
+    get ;;
+
+defcore contains? { argv argc }
+    0
+    argv cell+ @ \ key
+    argv @ \ coll
+    get 0 <> mal-bool ;;
 
 defcore nth ( argv[coll,i] argc )
     drop dup @ to-list ( argv list )
@@ -119,3 +168,51 @@ defcore first ( argv[coll] argc )
 
 defcore rest ( argv[coll] argc )
     drop @ to-list MalList/rest ;;
+
+defcore meta ( argv[obj] argc )
+    drop @ mal-meta @
+    ?dup 0= if mal-nil endif ;;
+
+defcore with-meta ( argv[obj,meta] argc )
+    drop ( argv )
+    dup cell+ @  swap @  ( meta obj )
+    dup mal-type @ MalTypeType-struct @ ( meta obj obj-size )
+    dup allocate throw { new-obj } ( meta obj obj-size )
+    new-obj swap cmove ( meta )
+    new-obj mal-meta ! ( )
+    new-obj ;;
+
+defcore atom ( argv[val] argc )
+    drop @ Atom. ;;
+
+defcore deref ( argv[atom] argc )
+    drop @ Atom/val @ ;;
+
+defcore reset! ( argv[atom,val] argc )
+    drop dup cell+ @ ( argv val )
+    dup -rot swap @ Atom/val ! ;;
+
+defcore apply { argv argc -- val }
+    \ argv is (fn args... more-args)
+    argv argc 1- cells + @ to-list { more-args }
+    argc 2 - { list0len }
+    more-args MalList/count @ list0len + { final-argc }
+    final-argc cells allocate throw { final-argv }
+    argv cell+   final-argv   list0len cells   cmove
+    more-args MalList/start @   final-argv list0len cells +  final-argc list0len - cells  cmove
+    final-argv final-argc argv @  invoke ;;
+
+
+defcore map?     drop @ mal-type @ MalMap     = mal-bool ;;
+defcore list?    drop @ mal-type @ MalList    = mal-bool ;;
+defcore vector?  drop @ mal-type @ MalVector  = mal-bool ;;
+defcore keyword? drop @ mal-type @ MalKeyword = mal-bool ;;
+defcore symbol?  drop @ mal-type @ MalSymbol  = mal-bool ;;
+defcore true?    drop @ mal-true  = mal-bool ;;
+defcore false?   drop @ mal-false = mal-bool ;;
+defcore nil?     drop @ mal-nil   = mal-bool ;;
+
+defcore sequential? drop @ sequential? ;;
+
+defcore keyword  drop @ unpack-str MalKeyword. ;;
+defcore symbol   drop @ unpack-str MalSymbol. ;;

forth/printer.fs

@@ -5,7 +5,6 @@ require types.fs
 
 def-protocol-method pr-buf ( readably? str-addr str-len this -- str-addr str-len )
 def-protocol-method pr-seq-buf ( readably? str-addr str-len this -- str-addr str-len )
-def-protocol-method pr-pairs-buf ( readably? str-addr str-len this -- str-addr str-len )
 
 : pr-str { obj }
     true new-str obj pr-buf rot drop ;
@@ -39,15 +38,6 @@ MalList
             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
-    list MalList/count @ 2 / 1 ?do
-        s" , " str-append
-        a-space
-        start i 2 * cells + @ pr-buf a-space
-        start i 2 * 1+ cells + @ pr-buf
-    loop ;;
 drop
 
 MalVector
@@ -62,7 +52,17 @@ MalMap
   extend pr-buf
     MalMap/list @
     -rot s" {" str-append ( list str-addr str-len )
-    rot pr-pairs-buf
+    rot { list }
+    list MalList/count @ { count }
+    count 0 > if
+        list MalList/start @ { start }
+        start @ pr-buf a-space start cell+ @ pr-buf
+        count 2 / 1 ?do
+            s" , " str-append
+            start i 2 * cells + @ pr-buf a-space
+            start i 2 * 1+ cells + @ pr-buf
+        loop
+    endif
     s" }" str-append ;;
 drop
 
@@ -105,3 +105,10 @@ MalString
         str-append
     endif ;;
 drop
+
+Atom
+  extend pr-buf { this }
+    s" (atom " str-append
+    this Atom/val @ pr-buf
+    s" )" str-append ;;
+drop

forth/step9_try.fs

@@ -5,10 +5,13 @@ require core.fs
 core MalEnv. constant repl-env
 
 \ Fully evalutate any Mal object:
-def-protocol-method mal-eval ( env ast -- val )
+\ 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 -- ... )
+\ def-protocol-method eval-invoke ( env list obj -- ... )
+
+\ Invoke a function, given parameter values
+\ def-protocol-method invoke ( argv argc mal-fn -- ... )
 
 99999999 constant TCO-eval
 
@@ -28,7 +31,7 @@ def-protocol-method invoke ( argv argc mal-fn -- ... )
 MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
 
 MalKeyword
-  extend invoke { env list kw -- val }
+  extend eval-invoke { env list kw -- val }
     0   kw   env list MalList/start @ cell+ @ eval   get
     ?dup 0= if
         \ compute not-found value
@@ -38,6 +41,15 @@ MalKeyword
             mal-nil
         endif
     endif ;;
+  extend invoke { argv argc kw -- val }
+    0   kw   argv @   get
+    ?dup 0= if
+        argc 1 > if
+            argv cell+ @
+        else
+            mal-nil
+        endif
+    endif ;;
 drop
 
 \ eval all but the first item of list
@@ -52,14 +64,15 @@ drop
     target argc ;
 
 MalNativeFn
-  extend invoke ( env list this -- list )
+  extend eval-invoke { env list this -- list }
-    MalNativeFn/xt @ { xt }
+    env list eval-rest ( argv argc )
-    eval-rest ( argv argc )
+    this invoke ;;
-    xt execute ( return-val ) ;;
+  extend invoke ( argv argc this -- val )
+    MalNativeFn/xt @ execute ;;
 drop
 
 SpecialOp
-  extend invoke ( env list this -- list )
+  extend eval-invoke ( env list this -- list )
     SpecialOp/xt @ execute ;;
 drop
 
@@ -191,12 +204,11 @@ s" &" MalSymbol. constant &-sym
         f-args i cells + @
         dup &-sym m= if
             drop
-            f-args i 1+ cells + @ ( more-args-symbol )
+            argc i - { c }
-            MalList new ( sym more-args )
+            c cells allocate throw { start }
-            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
+            f-args i 1+ cells + @ ( more-args-symbol )
+            start c MalList. env env/set
             leave
         endif
         argv i cells + @
@@ -205,13 +217,16 @@ s" &" MalSymbol. constant &-sym
     env ;
 
 MalUserFn
-  extend invoke { call-env list mal-fn -- list }
+  extend eval-invoke { call-env list mal-fn -- list }
     mal-fn MalUserFn/is-macro? @ if
         list MalList/start @ cell+  list MalList/count @ 1-
     else
         call-env list eval-rest
     endif
-    mal-fn new-user-fn-env { env }
+    mal-fn invoke ;;
+
+  extend invoke ( argv argc mal-fn )
+    dup { mal-fn } new-user-fn-env { env }
 
     mal-fn MalUserFn/is-macro? @ if
         env   mal-fn MalUserFn/body @   eval
@@ -224,6 +239,7 @@ drop
 defspecial fn* { env list -- val }
     list MalList/start @ cell+ { arg0 }
     MalUserFn new
+    false over MalUserFn/is-macro? !
     env over MalUserFn/env !
     arg0 @ to-list over MalUserFn/formal-args !
     arg0 cell+ @ over MalUserFn/body ! ;;
@@ -280,7 +296,7 @@ drop
 MalList
   extend mal-eval { env list -- val }
     env list MalList/start @ @ eval
-    env list rot invoke ;;
+    env list rot eval-invoke ;;
 drop
 
 MalVector
@@ -311,12 +327,30 @@ defcore eval ( argv argc )
     repeat
     2drop here>MalList ;
 
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: nop ;
+
+defcore map ( argv argc -- list )
+    drop dup @ swap cell+ @ to-list { fn list }
+    here
+    list MalList/start @   list MalList/count @  cells   over + swap   +do
+        i 1 fn invoke
+        dup TCO-eval = if drop eval endif
+        ,
+    cell +loop
+    here>MalList ;;
+
+defcore readline ( argv argc -- mal-string )
+    drop @ unpack-str type
+    buff 128 stdin read-line throw
+    if buff swap MalString. else mal-nil endif ;;
+
 s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
 s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep drop
 s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep drop
-
+s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep drop
-create buff 128 allot
-77777777777 constant stack-leak-detect
 
 : repl ( -- )
     begin
@@ -326,7 +360,7 @@ create buff 128 allot
     while ( num-bytes-read )
       buff swap ( str-addr str-len )
       ['] rep
-      \ execute type
+      execute ['] nop \ uncomment to see stack traces
       catch ?dup 0= if
           safe-type cr
           stack-leak-detect <> if ." --stack leak--" cr endif
@@ -358,3 +392,5 @@ create buff 128 allot
 main
 cr
 bye
+
+4

forth/types.fs

@@ -59,6 +59,7 @@ require str.fs
 
 struct
   cell% field mal-type
+  cell% field mal-meta
   \ cell% field ref-count \ Ha, right.
 end-struct MalType%
 
@@ -74,6 +75,7 @@ end-struct MalTypeType%
 : new ( MalTypeType -- obj )
   dup MalTypeType-struct 2@ %allocate throw ( MalTypeType obj ) \ create struct
   dup -rot mal-type !                       ( obj ) \ set struct's type pointer to this type
+  nil over mal-meta !
   ;
 
 : deftype* ( struct-align struct-len -- MalTypeType )
@@ -218,6 +220,7 @@ end-extend
 
 def-protocol-method conj ( obj this -- this )
 def-protocol-method assoc ( k v this -- this )
+def-protocol-method dissoc ( k this -- this )
 def-protocol-method get ( not-found k this -- value )
 def-protocol-method mal= ( a b -- bool )
 def-protocol-method as-native ( obj --  )
@@ -225,6 +228,20 @@ 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 )
+def-protocol-method sequential? ( obj -- mal-bool )
+
+
+\ 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 eval-invoke ( env list obj -- ... )
+
+\ Invoke a function, given parameter values
+def-protocol-method invoke ( argv argc mal-fn -- ... )
+
+
+
 
 : m= ( a b -- bool )
     2dup = if
@@ -259,6 +276,11 @@ MalType%
   cell% field MalList/start
 deftype MalList
 
+: MalList. ( start count -- mal-list )
+    MalList new
+    swap over MalList/count ! ( start list )
+    swap over MalList/start ! ( list ) ;
+
 : here>MalList ( old-here -- mal-list )
     here over - { bytes } ( old-here )
     MalList new bytes ( old-here mal-list bytes )
@@ -268,8 +290,22 @@ deftype MalList
     0 bytes - allot \ pop list contents from dictionary stack
     ;
 
+: MalList/concat ( list-of-lists )
+    dup MalList/start @ swap MalList/count @ { 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 start count MalList. ;
+
 MalList
   extend to-list ;;
+  extend sequential? drop mal-true ;;
   extend conj { elem old-list -- list }
     old-list MalList/count @ 1+ { new-count }
     new-count cells allocate throw { new-start }
@@ -277,10 +313,7 @@ MalList
     new-count 1 > if
       old-list MalList/start @   new-start cell+   new-count 1- cells  cmove
     endif
-
+    new-start new-count 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=
@@ -306,9 +339,9 @@ drop
 MalList new 0 over MalList/count ! constant MalList/Empty
 
 : MalList/rest { list -- list }
-    MalList new
+    list MalList/start @   cell+
-    list MalList/start @   cell+   over MalList/start !
+    list MalList/count @   1-
-    list MalList/count @   1-      over MalList/count ! ;
+    MalList. ;
 
 
 MalType%
@@ -316,6 +349,7 @@ MalType%
 deftype MalVector
 
 MalVector
+  extend sequential? drop mal-true ;;
   extend to-list
     MalVector/list @ ;;
   extend empty?
@@ -326,6 +360,15 @@ MalVector
     MalList/count @ MalInt. ;;
   extend mal=
     MalVector/list @ swap m= ;;
+  extend conj
+    MalVector/list @ { elem old-list }
+    old-list MalList/count @ { old-count }
+    old-count 1+ cells allocate throw { new-start }
+    elem new-start old-count cells + !
+    old-list MalList/start @   new-start old-count cells  cmove
+    new-start   old-count 1+  MalList.
+    MalVector new swap
+    over MalVector/list ! ;;
 drop
 
 MalType%
@@ -346,6 +389,19 @@ MalMap
     conj conj
     MalMap new dup -rot MalMap/list ! \ put back in map
     ;;
+  extend dissoc { k map -- map }
+    map MalMap/list @
+    dup MalList/start @ swap MalList/count @ { start count }
+    map \ return original if key not found
+    count 0 +do
+        start i cells + @ k mal= if
+            drop here
+            start i MalList. ,
+            start i 2 + cells +  count i - 2 - MalList. ,
+            here>MalList MalList/concat
+            MalMap new dup -rot MalMap/list ! \ put back in map
+        endif
+    2 +loop ;;
   extend get { not-found k map -- value }
     map MalMap/list @
     dup MalList/start @ { start }
@@ -377,12 +433,15 @@ MalDefault
   extend as-native ;; ( obj -- obj )
   extend to-list drop 0 ;;
   extend empty? drop mal-true ;;
+  extend sequential? drop mal-false ;;
 drop
 
 MalNil
   extend conj ( item nil -- mal-list )
     drop MalList/Empty conj ;;
   extend as-native drop 0 ;;
+  extend get drop 2drop mal-nil ;;
+  extend to-list drop MalList/Empty ;;
   extend empty? drop mal-true ;;
   extend mal-count drop 0 MalInt. ;;
   extend mal= drop mal-nil = ;;
@@ -499,3 +558,9 @@ deftype SpecialOp
 
 : SpecialOp.
     SpecialOp new swap over SpecialOp/xt ! ;
+
+MalType%
+  cell% field Atom/val
+deftype Atom
+
+: Atom. Atom new swap over Atom/val ! ;