forth: Add step 9, just try*/throw

- Moved some stuff out of printer into str,
  to support throwing strings in types.fs
- Fixed an apparently completely broken 'nth'
- Still failing 120 step9 tests

6 files changed, 456 insertions, 69 deletions

diff --git a/forth/core.fs b/forth/core.fs
index 43e6b75..c333131 100644
--- a/forth/core.fs
+++ b/forth/core.fs
@@ -98,11 +98,16 @@ defcore concat { lists argc }
     count over MalList/count ! ;;
 
 defcore nth ( argv[coll,i] argc )
-    over ( argv argc argv )
-    cell+ @ MalInt/int @ ( argv argc count )
-    swap over <= if ." nth out of bounds" cr 1 throw endif ( argv count )
-    cells swap ( c-offset argv )
-    @ to-list MalList/start @ + @ ;;
+    drop dup @ to-list ( argv list )
+    swap cell+ @ MalInt/int @ ( list i )
+    over MalList/count @ ( list i count )
+    2dup >= if { i count }
+        0 0
+        new-str i int>str str-append s\" \040>= " count int>str
+        s" nth out of bounds: " ...throw-str
+    endif drop ( list i )
+    cells swap ( c-offset list )
+    MalList/start @ + @ ;;
 
 defcore first ( argv[coll] argc )
     drop @ to-list
diff --git a/forth/printer.fs b/forth/printer.fs
index 5309745..645e5da 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -1,54 +1,6 @@
+require str.fs
 require types.fs
 
-: safe-type ( str-addr str-len -- )
-    dup 256 > if
-        drop 256 type ." ...<lots more>"
-    else
-        type
-    endif ;
-
-\ === mutable string buffer === /
-\ string buffer that maintains an allocation larger than the current
-\ string size.  When appending would cause the string size exceed the
-\ current allocation, resize is used to double the allocation. The
-\ current allocation is not stored anywhere, but computed based on
-\ current string size or str-base-size, whichever is larger.
-64 constant str-base-size
-
-: new-str ( -- addr length )
-  str-base-size allocate throw 0 ;
-
-: round-up ( n -- n )
-  2
-  begin
-    1 lshift 2dup <
-  until
-  nip ;
-
-: str-append { buf-addr buf-str-len str-addr str-len }
-  buf-str-len str-len +
-  { new-len }
-  new-len str-base-size >= if
-    buf-str-len new-len xor buf-str-len > if
-      buf-addr new-len round-up resize throw
-      to buf-addr
-    endif
-  endif
-  str-addr buf-addr buf-str-len + str-len cmove
-  buf-addr new-len ;
-
-\ define a-space, to append a space char to a string
-bl c,
-here constant space-str
-: a-space space-str 1 str-append ;
-
-: str-append-char ( buf-addr buf-str-len char -- buf-addr buf-str-len )
-    pad ! pad 1 str-append ;
-
-: int>str ( num -- str-addr str-len )
-  s>d <# #s #> ;
-
-
 \ === printer protocol and implementations === /
 
 def-protocol-method pr-buf ( readably? str-addr str-len this -- str-addr str-len )
diff --git a/forth/reader.fs b/forth/reader.fs
index 1daa650..134749b 100644
--- a/forth/reader.fs
+++ b/forth/reader.fs
@@ -66,7 +66,7 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     drop \ drop leading quote
     begin ( in-addr in-len )
         adv-str over 0= if
-            2drop s\" expected '\"', got EOF\n" safe-type 1 throw
+            2drop 0 0 s\" expected '\"', got EOF" ...throw-str
         endif
         dup [char] " <>
     while
@@ -87,9 +87,9 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     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
+            drop 2drop 0 0 s" ', got EOF"
+            close-char pad ! pad 1
+            s" expected '" ...throw-str
         endif
         dup close-char <>
     while ( str-addr str-len non-space-non-paren-char )
diff --git a/forth/step9_try.fs b/forth/step9_try.fs
new file mode 100644
index 0000000..5f8b189
--- /dev/null
+++ b/forth/step9_try.fs
@@ -0,0 +1,360 @@
+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 defmacro! { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    arg0 @ ( key )
+    env arg0 cell+ @ eval { val }
+    true val MalUserFn/is-macro? !
+    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
+
+: new-user-fn-env { argv argc mal-fn -- env }
+    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 ;
+
+MalUserFn
+  extend 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 MalUserFn/is-macro? @ if
+        env   mal-fn MalUserFn/body @   eval
+        env swap TCO-eval
+    else
+        env   mal-fn MalUserFn/body @   TCO-eval
+    endif ;;
+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 ! ;;
+
+defspecial macroexpand ( env list[_,form] -- form )
+    MalList/start @ cell+ @ swap over ( form env form )
+    MalList/start @ @ ( form env macro-name-expr )
+    eval { macro-fn } ( form )
+    dup MalList/start @ cell+  swap MalList/count @ 1- macro-fn ( argv argc fn )
+    new-user-fn-env ( env )
+    macro-fn MalUserFn/body @   TCO-eval ;;
+
+5555555555 constant pre-try
+
+defspecial try* { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    pre-try
+    env arg0 @ ['] eval catch ?dup 0= if
+        nip
+    else { errno }
+        begin pre-try = until
+        errno 1 <> if
+            s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
+            to exception-object
+        endif
+        arg0 cell+ @ ( list[catch*,sym,form] )
+        MalList/start @ cell+ { catch0 }
+        env MalEnv. { catch-env }
+        catch0 @ exception-object catch-env env/set
+        catch-env  catch0 cell+ @  TCO-eval
+    endif ;;
+
+defspecial throw ( env list -- )
+    MalList/start @ cell+ @ eval to exception-object
+    1 throw ;;
+
+MalSymbol
+  extend mal-eval { env sym -- val }
+    0 sym env get
+    dup 0= if
+        drop
+        0 0 s" ' not found" sym as-native s" '" ...throw-str
+    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
+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
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: repl ( -- )
+    begin
+      ." user> "
+      stack-leak-detect
+      buff 128 stdin read-line throw
+    while ( num-bytes-read )
+      buff swap ( str-addr str-len )
+      ['] rep
+      \ execute type
+      catch ?dup 0= if
+          safe-type cr
+          stack-leak-detect <> if ." --stack leak--" cr endif
+      else { errno }
+          begin stack-leak-detect = until
+          errno 1 <> if
+              s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
+              to exception-object
+          endif
+          ." Uncaught exception: "
+          exception-object pr-str safe-type 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/str.fs b/forth/str.fs
new file mode 100644
index 0000000..20aef32
--- /dev/null
+++ b/forth/str.fs
@@ -0,0 +1,73 @@
+: safe-type ( str-addr str-len -- )
+    dup 256 > if
+        drop 256 type ." ...<lots more>"
+    else
+        type
+    endif ;
+
+\ === mutable string buffer === /
+\ string buffer that maintains an allocation larger than the current
+\ string size.  When appending would cause the string size exceed the
+\ current allocation, resize is used to double the allocation. The
+\ current allocation is not stored anywhere, but computed based on
+\ current string size or str-base-size, whichever is larger.
+64 constant str-base-size
+
+: new-str ( -- addr length )
+  str-base-size allocate throw 0 ;
+
+: round-up ( n -- n )
+  2
+  begin
+    1 lshift 2dup <
+  until
+  nip ;
+
+: str-append { buf-addr buf-str-len str-addr str-len }
+  buf-str-len str-len +
+  { new-len }
+  new-len str-base-size >= if
+    buf-str-len new-len xor buf-str-len > if
+      buf-addr new-len round-up resize throw
+      to buf-addr
+    endif
+  endif
+  str-addr buf-addr buf-str-len + str-len cmove
+  buf-addr new-len ;
+
+\ define a-space, to append a space char to a string
+bl c,
+here constant space-str
+: a-space space-str 1 str-append ;
+
+: str-append-char ( buf-addr buf-str-len char -- buf-addr buf-str-len )
+    pad ! pad 1 str-append ;
+
+\ from gforth docs, there named 'my-.'
+: int>str ( num -- str-addr str-len )
+    \ handling negatives.. behaves like Standard .
+    s>d            \ convert to signed double
+    swap over dabs \ leave sign byte followed by unsigned double
+    <<#            \ start conversion
+    #s             \ convert all digits
+    rot sign       \ get at sign byte, append "-" if needed
+    #>             \ complete conversion
+    #>> ;          \ release hold area
+
+defer MalString.
+
+: ...str
+    new-str
+    begin
+        2swap
+        over 0 <>
+    while
+        str-append
+    repeat
+    2drop MalString. ;
+
+nil value exception-object
+
+: ...throw-str
+    ...str to exception-object
+    1 throw ;
diff --git a/forth/types.fs b/forth/types.fs
index 07eca02..d238001 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -1,3 +1,5 @@
+require str.fs
+
 \ === sorted-array === /
 \ Here are a few utility functions useful for creating and maintaining
 \ the deftype* method tables. The keys array is kept in sorted order,
@@ -131,10 +133,8 @@ MalType% deftype MalFalse MalFalse new constant mal-false
 \ themselves for the given object, and then execute that implementation.
 : execute-method { obj pxt -- }
   obj not-object? if
-      ." Refusing to invoke protocol fn '"
-      pxt >name name>string type
-      ." ' on non-object: " obj .
-      1 throw
+      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
@@ -148,12 +148,8 @@ MalType% deftype MalFalse MalFalse new constant mal-false
   endif
   0= if ( type idx )
       2drop
-      ." No protocol fn '"
-      pxt >name name>string type
-      ." ' extended to type '"
-      obj mal-type @ type-name type
-      ." '" cr
-      1 throw
+      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
 
@@ -449,11 +445,12 @@ MalType%
   cell% field MalString/str-len
 deftype MalString
 
-: MalString. { str-addr str-len -- mal-str }
+: MalString.0 { str-addr str-len -- mal-str }
     MalString new { str }
     str-addr str MalString/str-addr !
     str-len  str MalString/str-len  !
     str ;
+' MalString.0 is MalString.
 
 : unpack-str ( mal-string -- addr len )
     dup MalString/str-addr @