Merge pull request #8 from Chouser/forth3

Forth: Interop and perf updates

13 files changed, 205 insertions, 100 deletions

diff --git a/forth/env.fs b/forth/env.fs
index 1b5a362..9469bf2 100644
--- a/forth/env.fs
+++ b/forth/env.fs
@@ -15,25 +15,18 @@ deftype MalEnv
     key val env MalEnv/data @ assoc
     env MalEnv/data ! ;
 
-: env/find { key env -- env-or-0 }
+: env/get-addr { key env -- val-addr }
     env
     begin ( env )
-        dup 0 key rot MalEnv/data @ get ( env val-or-0 )
-        0= if ( env )
+        key over MalEnv/data @ MalMap/get-addr ( env addr-or-0 )
+        ?dup 0= if ( env )
             MalEnv/outer @ dup 0= ( env-or-0 done-looping? )
-        else
-            -1 \ found it! ( env -1 )
+        else ( env addr )
+            nip -1 \ found it! ( addr -1 )
         endif
     until ;
 
 MalEnv
-  extend get { not-found key env -- }
-    key env env/find ( env-or-0 )
-    ?dup 0= if
-        not-found
-    else ( env )
-        not-found key rot MalEnv/data @ get
-    endif ;;
   extend pr-buf { env }
     env MalEnv/data @ pr-buf
     a-space s" outer: " str-append
diff --git a/forth/misc-tests.fs b/forth/misc-tests.fs
index 35e665b..6b6d643 100644
--- a/forth/misc-tests.fs
+++ b/forth/misc-tests.fs
@@ -39,6 +39,7 @@ dup 5 cells + @  20 test=
 
 \ Protocol tests
 
+: t1
 mal-nil
 42 MalInt. mal-nil conj
 10 MalInt. mal-nil conj conj
@@ -80,14 +81,20 @@ drop
 
 99 MalInt. 10 MalInt. MalMap/Empty get 99 MalInt. test=
 
+;
+t1
+
 \ eval tests
 
 require step2_eval.fs
 
+: t2
 mal-nil
     1 MalInt. swap conj
     2 MalInt. swap conj
     3 MalInt. swap conj
 mal-eval
+;
+t2
 
 bye
diff --git a/forth/step2_eval.fs b/forth/step2_eval.fs
index 2b55ce0..724de44 100644
--- a/forth/step2_eval.fs
+++ b/forth/step2_eval.fs
@@ -6,12 +6,15 @@ require printer.fs
         argv i cells + @ as-native
     loop ;
 
+: env-assoc ( map sym-str-addr sym-str-len xt )
+    -rot MalSymbol. swap MalNativeFn. rot assoc ;
+
 MalMap/Empty
-    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
+    s" +" :noname args-as-native + MalInt. ; env-assoc
+    s" -" :noname args-as-native - MalInt. ; env-assoc
+    s" *" :noname args-as-native * MalInt. ; env-assoc
+    s" /" :noname args-as-native / MalInt. ; env-assoc
+constant repl-env
 
 : read read-str ;
 : eval ( env obj ) mal-eval ;
@@ -58,7 +61,7 @@ MalSymbol
     dup 0= if
         drop
         ." Symbol '"
-        sym as-native safe-type
+        sym pr-str safe-type
         ." ' not found." cr
         1 throw
     endif ;;
diff --git a/forth/step3_env.fs b/forth/step3_env.fs
index 676bfcc..a8a625e 100644
--- a/forth/step3_env.fs
+++ b/forth/step3_env.fs
@@ -91,13 +91,13 @@ defspecial let* { old-env list -- val }
 
 MalSymbol
   extend mal-eval { env sym -- val }
-    0 sym env get
+    sym env env/get-addr
     dup 0= if
         drop
-        ." Symbol '"
-        sym as-native safe-type
-        ." ' not found." cr
+        ." Symbol '" sym pr-str safe-type ." ' not found." cr
         1 throw
+    else
+        @
     endif ;;
 drop
 
diff --git a/forth/step4_if_fn_do.fs b/forth/step4_if_fn_do.fs
index 4fd277e..a3d64ac 100644
--- a/forth/step4_if_fn_do.fs
+++ b/forth/step4_if_fn_do.fs
@@ -151,13 +151,13 @@ defspecial fn* { env list -- val }
 
 MalSymbol
   extend mal-eval { env sym -- val }
-    0 sym env get
+    sym env env/get-addr
     dup 0= if
         drop
-        ." Symbol '"
-        sym as-native safe-type
-        ." ' not found." cr
+        ." Symbol '" sym pr-str safe-type ." ' not found." cr
         1 throw
+    else
+        @
     endif ;;
 drop
 
diff --git a/forth/step5_tco.fs b/forth/step5_tco.fs
index f7372db..421a2fc 100644
--- a/forth/step5_tco.fs
+++ b/forth/step5_tco.fs
@@ -162,13 +162,13 @@ defspecial fn* { env list -- val }
 
 MalSymbol
   extend mal-eval { env sym -- val }
-    0 sym env get
+    sym env env/get-addr
     dup 0= if
         drop
-        ." Symbol '"
-        sym as-native safe-type
-        ." ' not found." cr
+        ." Symbol '" sym pr-str safe-type ." ' not found." cr
         1 throw
+    else
+        @
     endif ;;
 drop
 
diff --git a/forth/step6_file.fs b/forth/step6_file.fs
index b3945ad..60b3817 100644
--- a/forth/step6_file.fs
+++ b/forth/step6_file.fs
@@ -162,13 +162,13 @@ defspecial fn* { env list -- val }
 
 MalSymbol
   extend mal-eval { env sym -- val }
-    0 sym env get
+    sym env env/get-addr
     dup 0= if
         drop
-        ." Symbol '"
-        sym as-native safe-type
-        ." ' not found." cr
+        ." Symbol '" sym pr-str safe-type ." ' not found." cr
         1 throw
+    else
+        @
     endif ;;
 drop
 
diff --git a/forth/step7_quote.fs b/forth/step7_quote.fs
index 0c6b909..1e4043d 100644
--- a/forth/step7_quote.fs
+++ b/forth/step7_quote.fs
@@ -204,13 +204,13 @@ defspecial fn* { env list -- val }
 
 MalSymbol
   extend mal-eval { env sym -- val }
-    0 sym env get
+    sym env env/get-addr
     dup 0= if
         drop
-        ." Symbol '"
-        sym as-native safe-type
-        ." ' not found." cr
+        ." Symbol '" sym pr-str safe-type ." ' not found." cr
         1 throw
+    else
+        @
     endif ;;
 drop
 
diff --git a/forth/step8_macros.fs b/forth/step8_macros.fs
index f01f3a9..7260567 100644
--- a/forth/step8_macros.fs
+++ b/forth/step8_macros.fs
@@ -232,13 +232,13 @@ defspecial macroexpand ( env list[_,form] -- form )
 
 MalSymbol
   extend mal-eval { env sym -- val }
-    0 sym env get
+    sym env env/get-addr
     dup 0= if
         drop
-        ." Symbol '"
-        sym as-native safe-type
-        ." ' not found." cr
+        ." Symbol '" sym pr-str safe-type ." ' not found." cr
         1 throw
+    else
+        @
     endif ;;
 drop
 
diff --git a/forth/step9_try.fs b/forth/step9_try.fs
index e11c691..681e608 100644
--- a/forth/step9_try.fs
+++ b/forth/step9_try.fs
@@ -263,10 +263,12 @@ defspecial try* { env list -- val }
 
 MalSymbol
   extend mal-eval { env sym -- val }
-    0 sym env get
+    sym env env/get-addr
     dup 0= if
         drop
-        0 0 s" ' not found" sym as-native s" '" ...throw-str
+        0 0 s" ' not found" sym pr-str s" '" ...throw-str
+    else
+        @
     endif ;;
 drop
 
diff --git a/forth/stepA_interop.fs b/forth/stepA_interop.fs
index 0a4050a..af5f5d8 100644
--- a/forth/stepA_interop.fs
+++ b/forth/stepA_interop.fs
@@ -261,12 +261,21 @@ defspecial try* { env list -- val }
         catch-env  catch0 cell+ @  TCO-eval
     endif ;;
 
+defspecial . { env coll -- rtn-list }
+    depth { old-depth }
+    coll to-list dup MalList/count @ swap MalList/start @ { count start }
+    count cells start +  start cell+  +do
+        env i @ eval as-native
+    cell +loop ;;
+
 MalSymbol
   extend mal-eval { env sym -- val }
-    0 sym env get
+    sym env env/get-addr
     dup 0= if
         drop
-        0 0 s" ' not found" sym as-native s" '" ...throw-str
+        0 0 s" ' not found" sym pr-str s" '" ...throw-str
+    else
+        @
     endif ;;
 drop
 
diff --git a/forth/tests/stepA_interop.mal b/forth/tests/stepA_interop.mal
new file mode 100644
index 0000000..c4a0e75
--- /dev/null
+++ b/forth/tests/stepA_interop.mal
@@ -0,0 +1,41 @@
+;; Basic interop
+(. 5 'MalInt.)
+;=>5
+(. 11 31 '+ 'MalInt.)
+;=>42
+(. "greetings" 'MalString.)
+;=>"greetings"
+(. "hello" 'type 'cr 'mal-nil)
+; hello
+;=>nil
+
+;; Interop on non-literals
+(. (+ 15 27) 'MalInt.)
+;=>42
+(let* [a 17] (. a 25 '+ 'MalInt.))
+;=>42
+(let* [a "hello"] (. a 1 '- 'MalString.))
+;=>"hell"
+
+;; Use of annoyingly-named forth words
+(. 1 'MalInt. (symbol ",") 'here (symbol "@"))
+;=>1
+(let* (i 'MalInt.) (. 5 i))
+;=>5
+(let* (comma (symbol ",") fetch (symbol "@")) (. 'here 42 'MalInt. comma fetch))
+;=>42
+
+;; Multiple .-forms interacting via heap memory and mal locals
+(def! string-parts (fn* (s) (. s 'MalInt. 'swap 'MalInt. 'here '-rot (symbol ",") (symbol ",") 'here>MalList)))
+(first (rest (string-parts "sketchy")))
+;=>7
+(def! prn-chars (fn* (start count) (if (> count 0) (do (prn (. start 1 'MalString.)) (prn-chars (+ start 1) (- count 1))))))
+(let* (msg (string-parts "sketchy")) (prn-chars (first msg) (first (rest msg))))
+; "s"
+; "k"
+; "e"
+; "t"
+; "c"
+; "h"
+; "y"
+;=>nil
diff --git a/forth/types.fs b/forth/types.fs
index 2c4c8e0..2fceccf 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -132,38 +132,60 @@ MalType% deftype MalFalse MalFalse new constant mal-false
 
 \ === protocol methods === /
 
-0 constant trace
+struct
+    cell% field call-site/type
+    cell% field call-site/xt
+end-struct call-site%
 
 \ Used by protocol methods to find the appropriate implementation of
 \ themselves for the given object, and then execute that implementation.
-: execute-method { obj pxt -- }
+: execute-method { obj pxt call-site -- }
   obj not-object? if
       0 0 obj int>str s" ' on non-object: " pxt >name name>string
       s" Refusing to invoke protocol fn '" ...throw-str
   endif
-  obj mal-type @ dup MalTypeType-methods 2@ swap ( type methods method-keys )
-  dup 0= if \ No protocols extended to this type; check for a default
-    2drop drop MalDefault MalTypeType-methods 2@ swap
-  endif
+  \ ." Calling '" pxt >name name>string type ." ' on " obj mal-type @ type-name type ." , cs " call-site .
 
-  pxt array-find ( type idx found? )
-  dup 0= if \ No implementation found for this method; check for a default
-    2drop drop MalDefault dup MalTypeType-methods 2@ swap
-    pxt array-find ( type idx found? )
-  endif
-  0= if ( type idx )
-      2drop
-      0 0 s" '" obj mal-type @ type-name s" ' extended to type '"
-      pxt >name name>string s" No protocol fn '" ...throw-str
-  endif
-  trace if ." Calling '" pxt >name name>string type ." ' on " obj mal-type @ type-name type cr endif
+  obj mal-type @ ( type )
+  dup call-site call-site/type @ = if
+      \ ." hit!" cr
+      drop
+      call-site call-site/xt @
+  else
+      \ ." miss!" cr
+      dup MalTypeType-methods 2@ swap ( type methods method-keys )
+      dup 0= if \ No protocols extended to this type; check for a default
+          2drop drop MalDefault MalTypeType-methods 2@ swap
+      endif
+
+      pxt array-find ( type idx found? )
+      dup 0= if \ No implementation found for this method; check for a default
+          2drop drop MalDefault dup MalTypeType-methods 2@ swap
+          pxt array-find ( type idx found? )
+      endif
+      0= if ( type idx )
+          2drop
+          0 0 s" '" obj mal-type @ type-name s" ' extended to type '"
+          pxt >name name>string s" No protocol fn '" ...throw-str
+      endif
 
-  cells swap MalTypeType-method-vals @ + @ ( xt )
+      cells over MalTypeType-method-vals @ + @ ( type xt )
+      swap call-site call-site/type ! ( xt )
+      dup call-site call-site/xt ! ( xt )
+  endif
   obj swap execute ;
 
 \ Extend a type with a protocol method. This mutates the MalTypeType
 \ object that represents the MalType being extended.
 : extend-method* { type pxt ixt -- type }
+  \ ." Extend '" pxt dup . >name name>string safe-type ." ' to " type type-name safe-type ." , "
+  \ type MalTypeType-methods 2@ ( method-keys methods )
+  \   0 ?do
+  \       dup i cells + @ >name name>string safe-type ." , "
+  \       \ dup i cells + @ .
+  \   loop
+  \   drop cr
+
   type MalTypeType-methods 2@ swap ( methods method-keys )
   dup 0= if \ no protocols extended to this type
     2drop
@@ -189,12 +211,28 @@ MalType% deftype MalFalse MalFalse new constant mal-false
   ;
 
 
-\ def-protocol-method pr-str   ...can be written:
-\ : pr-str ( obj -- str ) [ latestxt ] literal execute-method ;
-: def-protocol-method ( "name" -- )
-    create latestxt ,
-  does> ( ??? obj xt-ref -- ??? )
-    @ execute-method ;
+\ Define a new protocol function.  For example:
+\   def-protocol-method pr-str
+\ When called as above, defines a new word 'pr-str' and stores there its
+\ own xt (known as pxt). When a usage of pr-str is compiled, it
+\ allocates a call-site object on the heap and injects a reference to
+\ both that and the pxt into the compilation, along with a call to
+\ execute-method. Thus when pr-str runs, execute-method can check the
+\ call-site object to see if the type of the target object is the same
+\ as the last call for this site. If so, it executes the implementation
+\ immediately. Otherwise, it searches the target type's method list and
+\ if necessary MalDefault's method list. If an implementation of pxt is
+\ found, it is cached in the call-site, and then executed.
+: make-call-site { pxt -- }
+    pxt postpone literal \ transfer pxt into call site
+    call-site% %allocate throw dup postpone literal \ allocate call-site, push reference
+    \ dup ." Make cs '" pxt >name name>string type ." ' " . cr
+    0 swap call-site/type !
+    postpone execute-method ;
+
+: def-protocol-method ( parse: name -- )
+    : latestxt postpone literal postpone make-call-site postpone ; immediate
+    ;
 
 : extend ( type -- type pxt install-xt <noname...>)
     parse-name find-name name>int ( type pxt )
@@ -234,6 +272,8 @@ 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 )
+def-protocol-method get-map-hint ( obj -- hint )
+def-protocol-method set-map-hint! ( hint obj -- )
 
 
 \ Fully evalutate any Mal object:
@@ -384,6 +424,32 @@ deftype MalMap
 
 MalMap new MalList/Empty over MalMap/list ! constant MalMap/Empty
 
+: MalMap/get-addr ( k map -- addr-or-nil )
+    MalMap/list @
+    dup MalList/start @
+    swap MalList/count @ { k start count }
+    true \ need to search?
+    k get-map-hint { hint-idx }
+    hint-idx -1 <> if
+        hint-idx count < if
+            hint-idx cells start + { key-addr }
+            key-addr @ k m= if
+                key-addr cell+
+                nip false
+            endif
+        endif
+    endif
+    if \ search
+        nil ( addr )
+        count cells start +  start  +do
+            i @ k m= if
+                drop i
+                dup start - cell / k set-map-hint!
+                cell+ leave
+            endif
+        [ 2 cells ] literal +loop
+    endif ;
+
 MalMap
   extend conj ( kv map -- map )
     MalMap/list @ \ get list
@@ -394,7 +460,7 @@ MalMap
   extend assoc ( k v map -- map )
     MalMap/list @ \ get list
     conj conj
-    MalMap new dup -rot MalMap/list ! \ put back in map
+    MalMap new tuck MalMap/list ! \ put back in map
     ;;
   extend dissoc { k map -- map }
     map MalMap/list @
@@ -409,22 +475,9 @@ MalMap
             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 }
-    MalList/count @ { count }
-    0
-    begin
-        dup count >= if
-            drop not-found true
-        else
-            start over cells + @ k m= if
-                start swap cells + cell+ @ true \ found it ( value true )
-            else
-                2 + false
-            endif
-        endif
-    until ;;
+  extend get ( not-found k map -- value )
+    MalMap/get-addr ( not-found addr-or-nil )
+    dup 0= if drop else nip @ endif ;;
   extend empty?
     MalMap/list @
     MalList/count @ 0= mal-bool ;;
@@ -437,17 +490,18 @@ drop
 MalDefault
   extend conj   ( obj this -- this )
     nip ;;
-  extend as-native ;; ( obj -- obj )
   extend to-list drop 0 ;;
   extend empty? drop mal-true ;;
   extend sequential? drop mal-false ;;
   extend mal= = ;;
+  extend get-map-hint drop -1 ;;
+  extend set-map-hint! 2drop ;;
 drop
 
 MalNil
   extend conj ( item nil -- mal-list )
     drop MalList/Empty conj ;;
-  extend as-native drop 0 ;;
+  extend as-native drop nil ;;
   extend get 2drop ;;
   extend to-list drop MalList/Empty ;;
   extend empty? drop mal-true ;;
@@ -458,14 +512,14 @@ drop
 MalType%
   cell% field MalSymbol/sym-addr
   cell% field MalSymbol/sym-len
-  cell% field MalSymbol/meta
+  cell% field MalSymbol/map-hint
 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  !
+    str-len  sym MalSymbol/sym-len !
+    -1       sym MalSymbol/map-hint !
     sym ;
 
 : unpack-sym ( mal-string -- addr len )
@@ -479,7 +533,10 @@ MalSymbol
     else
         2drop 0
     endif ;;
-  ' as-native ' unpack-sym extend-method*
+  extend get-map-hint MalSymbol/map-hint @ ;;
+  extend set-map-hint! MalSymbol/map-hint ! ;;
+  extend as-native ( this )
+    unpack-sym evaluate ;;
 drop
 
 MalType%
@@ -536,20 +593,13 @@ drop
 
 MalType%
   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 ;
 
-MalNativeFn
-  extend as-native
-    MalNativeFn/xt @ ;;
-drop
-
 
 MalType%
   cell% field MalUserFn/is-macro?