forth: Add step 2

5 files changed, 387 insertions, 32 deletions

diff --git a/forth/misc-tests.fs b/forth/misc-tests.fs
index 5aaf2f2..c428a12 100644
--- a/forth/misc-tests.fs
+++ b/forth/misc-tests.fs
@@ -51,3 +51,31 @@ mal-nil
 20 MalInt. swap conj
 23 MalInt. mal-nil conj conj conj
 pr-str s" (nil (20 (42) 10) 23)" str= -1 test=
+
+\ map tests
+
+s" one" MalString. s" one" MalString. mal= -1 test=
+s" one" MalString. s" x" MalString. mal= 0 test=
+
+MalMap/Empty
+s" one" MalString. s" first" MalString. rot assoc
+s" two" MalString. s" second" MalString. rot assoc
+s" three" MalString. s" third" MalString. rot assoc
+
+dup 99 s" two" MalString. rot get s" second" MalString. mal= -1 test=
+dup 99 s" none" MalString. rot get 99 test=
+drop
+
+\ eval tests
+
+require step2_eval.fs
+
+mal-nil
+    1 MalInt. swap conj
+    2 MalInt. swap conj
+    3 MalInt. swap conj
+~~
+mal-eval
+~~
+
+bye
diff --git a/forth/printer.fs b/forth/printer.fs
index 1244c08..d85e38b 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -2,7 +2,7 @@ require types.fs
 
 : safe-type ( str-addr str-len -- )
     dup 256 > if
-        drop 256 type ." ...<lots more>" type
+        drop 256 type ." ...<lots more>"
     else
         type
     endif ;
@@ -52,6 +52,8 @@ here constant space-str
 \ === printer protocol and implementations === /
 
 def-protocol-method pr-buf ( str-addr str-len this -- str-addr str-len )
+def-protocol-method pr-seq-buf ( str-addr str-len this -- str-addr str-len )
+def-protocol-method pr-pairs-buf ( str-addr str-len this -- str-addr str-len )
 
 : pr-str { obj }
     new-str obj pr-buf ;
@@ -73,27 +75,59 @@ drop
 : pr-buf-list-item ( list str-addr str-len -- list str-addr str-len)
     rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf ;
 
-: pr-buf-list ( list str-addr str-len -- str-addr str-len)
-    pr-buf-list-item
+MalList
+  extend pr-buf
+    -rot s" (" str-append ( list str-addr str-len )
+    rot pr-seq-buf
+    s" )" str-append ;;
+  extend pr-seq-buf
+    \ currently assumes list chain through to the end
+    -rot pr-buf-list-item
     begin ( list str-addr str-len )
       2 pick mal-nil <>
     while
       a-space pr-buf-list-item
     repeat
-    rot drop ;
+    rot drop ;;
+  extend pr-pairs-buf
+    -rot pr-buf-list-item a-space pr-buf-list-item
+    begin ( list str-addr str-len )
+      2 pick mal-nil <>
+    while
+      s" , " str-append
+      pr-buf-list-item a-space pr-buf-list-item
+    repeat
+    rot drop ;;
+drop
 
-MalList
+MalArray
   extend pr-buf
     -rot s" (" str-append ( list str-addr str-len )
-    pr-buf-list
+    rot pr-seq-buf
     s" )" str-append ;;
+  extend pr-seq-buf { ary }
+    ary MalArray/start @ { start }
+    start @ pr-buf
+    ary MalArray/count @ 1 ?do
+        a-space
+        start i cells + @ pr-buf
+    loop ;;
+  extend pr-pairs-buf { ary }
+    ary MalArray/start @ { start }
+    start @ pr-buf a-space start cell+ @ pr-buf
+    ary MalArray/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
   extend pr-buf
     MalVector/list @
     -rot s" [" str-append ( list str-addr str-len )
-    pr-buf-list
+    rot pr-seq-buf
     s" ]" str-append ;;
 drop
 
@@ -101,14 +135,7 @@ MalMap
   extend pr-buf
     MalMap/list @
     -rot s" {" str-append ( list str-addr str-len )
-    pr-buf-list-item a-space pr-buf-list-item
-    begin ( list str-addr str-len )
-      2 pick mal-nil <>
-    while
-      s" , " str-append
-      pr-buf-list-item a-space pr-buf-list-item
-    repeat
-    rot drop
+    rot pr-pairs-buf
     s" }" str-append ;;
 drop
 
@@ -117,11 +144,20 @@ MalInt
     MalInt/int @ int>str str-append ;;
 drop
 
+MalFn
+  extend pr-buf
+    drop s" #<fn>" str-append ;;
+drop
+
 MalSymbol
   extend pr-buf
-    dup MalSymbol/sym-addr @
-    swap MalSymbol/sym-len @
-    str-append ;;
+    unpack-sym str-append ;;
+drop
+
+MalKeyword
+  extend pr-buf { kw }
+    s" :" str-append
+    kw unpack-keyword str-append ;;
 drop
 
 : insert-\ ( str-addr str-len insert-idx -- str-addr str-len )
diff --git a/forth/reader.fs b/forth/reader.fs
index 7ff46fd..edd99fc 100644
--- a/forth/reader.fs
+++ b/forth/reader.fs
@@ -90,7 +90,8 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     drop adv-str \ skip trailing quote
     out-addr out-len MalString. ;
 
-: read-list ( str-addr str-len open-paren-char -- str-addr str-len non-paren-char mal-list )
+: read-list ( str-addr str-len open-paren-char close-paren-char
+              -- str-addr str-len non-paren-char mal-list )
     \ push objects onto "dictionary" -- maybe not the best stack for this?
     0 { close-char len }
     drop adv-str
@@ -112,7 +113,25 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     len 0 ?do
         0 cell - allot
         here @ swap conj
-    loop
+    loop ;
+
+: read-array ( str-addr str-len open-paren-char close-paren-char
+                 -- str-addr str-len non-paren-char mal-array )
+    here { close-char old-here }
+    drop adv-str
+    begin ( str-addr str-len char )
+        skip-spaces ( str-addr str-len non-space-char )
+        over 0= if
+            drop 2drop
+            s\" expected '" close-char str-append-char
+            s\" ', got EOF" str-append safe-type 1 throw
+        endif
+        dup close-char <>
+    while ( str-addr str-len non-space-non-paren-char )
+            read-form ,
+    repeat
+    drop adv-str
+    old-here here>MalArray
     ;
 
 : read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list )
@@ -124,11 +143,12 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     begin
         skip-spaces
         dup mal-digit? if read-int else
-        dup [char] ( = if [char] ) read-list else
-        dup [char] [ = if [char] ] read-list MalVector new tuck MalVector/list ! else
+        dup [char] ( = if [char] ) read-array else
+        dup [char] [ = if [char] ] read-array MalVector new tuck MalVector/list ! else
         dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else
         dup [char] " = if read-string-literal else
         dup [char] ; = if read-comment 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
@@ -146,7 +166,7 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
             s" with-meta" MalSymbol. swap conj
         else
             read-symbol-str MalSymbol.
-        endif endif endif endif endif endif endif endif endif endif endif
+        endif endif endif endif endif endif endif endif endif endif endif endif
         dup skip-elem =
     while drop repeat ;
 ' read-form2 is read-form
diff --git a/forth/step2_eval.fs b/forth/step2_eval.fs
new file mode 100644
index 0000000..51d1f6f
--- /dev/null
+++ b/forth/step2_eval.fs
@@ -0,0 +1,106 @@
+require reader.fs
+require printer.fs
+
+: args-as-native { argv argc -- entry*argc... }
+    argc 0 ?do
+        argv i cells + @ as-native
+    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
+value repl-env
+
+def-protocol-method mal-eval ( env ast -- val )
+def-protocol-method mal-eval-ast ( env ast -- val )
+
+MalDefault extend mal-eval nip ;; drop
+
+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
+
+MalArray
+  extend mal-eval { env ary -- val }
+    \ Pass args on dictionary stack (!)
+    \ TODO: consider allocate and free of a real MalArray instead
+    here { val-start }
+    ary MalArray/start @ { expr-start }
+    ary MalArray/count @ 0 ?do
+        env expr-start i cells + @ mal-eval ,
+    loop
+    val-start cell+  here val-start - cell / 1-  val-start @  ( argv argc MalFn )
+    invoke
+    val-start here - allot ;;
+  extend mal-eval-ast { env ary -- ary }
+    here
+    ary MalArray/start @ { expr-start }
+    ary MalArray/count @ 0 ?do
+        env expr-start i cells + @ mal-eval ,
+    loop
+    here>MalArray ;;
+drop
+
+MalList
+  extend mal-eval-ast { env list -- ary }
+    here
+    list
+    begin ( list )
+        dup mal-nil <>
+    while
+        env over MalList/car @ mal-eval ,
+        MalList/cdr @
+    repeat
+    drop here>MalArray ;;
+drop
+
+MalVector
+  extend mal-eval ( env vector -- vector )
+    MalVector/list @ mal-eval-ast
+    MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+  extend mal-eval ( env map -- map )
+    MalMap/list @ mal-eval-ast
+    MalMap new swap over MalMap/list ! ;;
+drop
+
+: read read-str ;
+: eval ( env obj ) mal-eval ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
+
+: rep ( str -- val )
+    read
+    repl-env swap eval
+    print ;
+
+create buff 128 allot
+
+: read-lines
+    begin
+      ." user> "
+      buff 128 stdin read-line throw
+    while
+      buff swap
+      ['] rep
+      \ execute safe-type
+      catch 0= if safe-type else ." Caught error" endif
+      cr
+    repeat ;
+
+read-lines
+cr
+bye
diff --git a/forth/types.fs b/forth/types.fs
index 2933448..2c4d178 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -65,6 +65,8 @@ struct
   cell% field MalTypeType-methods
   cell% field MalTypeType-method-keys
   cell% field MalTypeType-method-vals
+  cell% field MalTypeType-name-addr
+  cell% field MalTypeType-name-len
 end-struct MalTypeType%
 
 : new ( MalTypeType -- obj )
@@ -79,12 +81,31 @@ end-struct MalTypeType%
   dup MalTypeType-methods     0   swap !   ( MalTypeType )
   dup MalTypeType-method-keys nil swap !   ( MalTypeType )
   dup MalTypeType-method-vals nil swap !   ( MalTypeType )
+  dup MalTypeType-name-len    0   swap !   ( MalTypeType )
   ;
 
-MalType% deftype* constant MalDefault
+: 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
+
+    \ allot and initialize type structure
+    deftype* { mt }
+    name-addr mt MalTypeType-name-addr !
+    name-len  mt MalTypeType-name-len  !
+    \ ." Defining " mt MalTypeType-name-addr @ mt MalTypeType-name-len @ type cr
+    mt name-addr name-len nextname 1 0 const-does> ;
+
+: type-name ( mal-type )
+    dup  MalTypeType-name-addr @ ( mal-type name-addr )
+    swap MalTypeType-name-len @ ( name-addr name-len )
+    ;
+
+MalType% deftype MalDefault
 
 \ nil type and instance to support extending protocols to it
-MalType% deftype* constant MalNil
+MalType% deftype MalNil
 MalNil new constant mal-nil
 
 \ === protocol methods === /
@@ -104,7 +125,15 @@ MalNil new constant mal-nil
     dup 0= if ." No implementation found for this method, and no protocols extended to MalDefault" 1 throw endif
     pxt array-find ( type idx found? )
   endif
-  0= if ." No implementation found" 1 throw endif
+  0= if ( type idx )
+      2drop
+      ." No protocol fn '"
+      pxt >name name>string type
+      ." ' extended to type '"
+      obj mal-type @ type-name type
+      ." '"
+      1 throw
+  endif
 
   cells swap MalTypeType-method-vals @ + @ ( xt )
   obj swap execute
@@ -174,7 +203,7 @@ end-extend
 MalType%
   cell% field MalList/car
   cell% field MalList/cdr
-deftype* constant MalList
+deftype MalList
 
 : MalList/conj { val coll -- list }
     MalList new ( list )
@@ -182,24 +211,77 @@ deftype* constant MalList
     coll over MalList/cdr ! ( list )
     ;
 
+MalType%
+  cell% field MalArray/count
+  cell% field MalArray/start
+deftype MalArray
+
+: here>MalArray ( old-here -- mal-array )
+    here over - { bytes } ( old-here )
+    MalArray new bytes ( old-here mal-array bytes )
+    allocate throw dup { target } over MalArray/start ! ( old-here mal-array )
+    bytes cell / over MalArray/count ! ( old-here mal-array )
+    swap target bytes cmove ( mal-array )
+    0 bytes - allot \ pop array contents from dictionary stack
+    ;
+
 def-protocol-method conj ( obj this -- this )
+def-protocol-method assoc ( k v this -- this )
+def-protocol-method get ( not-found k this -- value )
+def-protocol-method mal= ( a b -- bool )
+def-protocol-method as-native ( obj --  )
+def-protocol-method invoke ( argv argc mal-fn -- ... )
 
 MalType%
   cell% field MalVector/list
-deftype* constant MalVector
+deftype MalVector
 
 MalType%
   cell% field MalMap/list
-deftype* constant MalMap
+deftype MalMap
+
+MalMap new mal-nil over MalMap/list ! constant MalMap/Empty
+
+MalMap
+  extend conj ( kv map -- map )
+    MalMap/list @ \ get list
+    over MalList/cdr @ MalList/car @ conj \ add value
+    swap MalList/car @ conj \ add key
+    MalMap new MalMap/list ! \ put back in map
+    ;;
+  extend assoc ( k v map -- map )
+    MalMap/list @ \ get list
+    conj conj
+    MalMap new dup -rot MalMap/list ! \ put back in map
+    ;;
+  extend get ( not-found k map -- value )
+    -rot { not-found k }
+    MalMap/list @ \ get list
+    begin
+        dup MalList/cdr @
+        swap MalList/car @ k mal= if
+            MalList/car @ -1 \ found it
+        else
+            MalList/cdr @
+            dup mal-nil = if
+                not-found -1
+            else
+                0
+            endif
+        endif
+    until ;;
+drop
 
 \ Examples of extending existing protocol methods to existing type
 MalDefault
   extend conj   ( obj this -- this )
     nip ;;
+  extend as-native ;; ( obj -- obj )
 drop
 
 MalNil
   ' conj ' MalList/conj extend-method*
+  extend as-native drop 0 ;;
 drop
 
 MalList
@@ -209,30 +291,113 @@ drop
 
 MalType%
   cell% field MalInt/int
-deftype* constant MalInt
+deftype MalInt
 
 : MalInt. { int -- mal-int }
     MalInt new dup MalInt/int int swap ! ;
 
+MalInt
+  extend as-native ( mal-int -- int )
+    MalInt/int @ ;;
+drop
+
 MalType%
   cell% field MalSymbol/sym-addr
   cell% field MalSymbol/sym-len
   cell% field MalSymbol/meta
-deftype* constant MalSymbol
+deftype MalSymbol
 
 : MalSymbol. { str-addr str-len -- mal-sym }
     MalSymbol new { sym }
     str-addr sym MalSymbol/sym-addr !
     str-len  sym MalSymbol/sym-len  !
+    MalMap/Empty sym MalSymbol/meta  !
     sym ;
 
+: unpack-sym ( mal-string -- addr len )
+    dup MalSymbol/sym-addr @
+    swap MalSymbol/sym-len @ ;
+
+MalSymbol
+  extend mal= ( other this -- bool )
+    over mal-type @ MalSymbol = if
+        unpack-sym rot unpack-sym str=
+    else
+        2drop 0
+    endif ;;
+  ' as-native ' unpack-sym extend-method*
+drop
+
+MalType%
+  cell% field MalKeyword/str-addr
+  cell% field MalKeyword/str-len
+deftype MalKeyword
+
+: unpack-keyword ( mal-keyword -- addr len )
+    dup MalKeyword/str-addr @
+    swap MalKeyword/str-len @ ;
+
+MalKeyword
+  extend mal= ( other this -- bool )
+    over mal-type @ MalKeyword = if
+        unpack-keyword rot unpack-keyword str=
+    else
+        2drop 0
+    endif ;;
+  ' as-native ' unpack-keyword extend-method*
+  extend invoke { argv argc kw -- val }
+    argc 1 > if argv cell+ @ else mal-nil endif \ not-found
+    kw \ key
+    argv @ \ map
+    get ;;
+drop
+
+: MalKeyword. { str-addr str-len -- mal-keyword }
+    MalKeyword new { kw }
+    str-addr kw MalKeyword/str-addr !
+    str-len  kw MalKeyword/str-len  !
+    kw ;
+
 MalType%
   cell% field MalString/str-addr
   cell% field MalString/str-len
-deftype* constant MalString
+deftype MalString
 
 : MalString. { str-addr str-len -- mal-str }
     MalString new { str }
     str-addr str MalString/str-addr !
     str-len  str MalString/str-len  !
     str ;
+
+: unpack-str ( mal-string -- addr len )
+    dup MalString/str-addr @
+    swap MalString/str-len @ ;
+
+MalString
+  extend mal= ( other this -- bool )
+    over mal-type @ MalString = if
+        unpack-str rot unpack-str str=
+    else
+        2drop 0
+    endif ;;
+  ' as-native ' unpack-str extend-method*
+drop
+
+
+MalType%
+  cell% field MalFn/xt
+  cell% field MalFn/meta
+deftype MalFn
+
+: MalFn. { xt -- mal-fn }
+    MalFn new { mal-fn }
+    xt mal-fn MalFn/xt !
+    MalMap/Empty mal-fn MalFn/meta  !
+    mal-fn ;
+
+MalFn
+  extend invoke ( ... mal-fn -- ... )
+    MalFn/xt @ execute ;;
+  extend as-native
+    MalFn/xt @ ;;
+drop