forth/step5_tco.fs

   1 require reader.fs
   2 require printer.fs
   3 require core.fs
   4
   5 core MalEnv. constant repl-env
   6
   7 99999999 constant TCO-eval
   8
   9 : read read-str ;
  10 : eval ( env obj )
  11     begin
  12         \ ." eval-> " dup pr-str safe-type cr
  13         mal-eval
  14         dup TCO-eval =
  15     while
  16         drop
  17     repeat ;
  18 : print
  19     \ ." Type: " dup mal-type @ type-name safe-type cr
  20     pr-str ;
  21
  22 MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
  23
  24 MalKeyword
  25   extend eval-invoke { env list kw -- val }
  26     0   kw   env list MalList/start @ cell+ @ eval   get
  27     ?dup 0= if
  28         \ compute not-found value
  29         list MalList/count @ 1 > if
  30             env  list MalList/start @ 2 cells + @  TCO-eval
  31         else
  32             mal-nil
  33         endif
  34     endif ;;
  35 drop
  36
  37 \ eval all but the first item of list
  38 : eval-rest { env list -- argv argc }
  39     list MalList/start @ cell+ { expr-start }
  40     list MalList/count @ 1- { argc }
  41     argc cells allocate throw { target }
  42     argc 0 ?do
  43         env expr-start i cells + @ eval
  44         target i cells + !
  45     loop
  46     target argc ;
  47
  48 MalNativeFn
  49   extend eval-invoke ( env list this -- list )
  50     MalNativeFn/xt @ { xt }
  51     eval-rest ( argv argc )
  52     xt execute ( return-val ) ;;
  53 drop
  54
  55 SpecialOp
  56   extend eval-invoke ( env list this -- list )
  57     SpecialOp/xt @ execute ;;
  58 drop
  59
  60 : install-special ( symbol xt )
  61     SpecialOp. repl-env env/set ;
  62
  63 : defspecial
  64     parse-allot-name MalSymbol.
  65     ['] install-special
  66     :noname
  67     ;
  68
  69 defspecial quote ( env list -- form )
  70     nip MalList/start @ cell+ @ ;;
  71
  72 defspecial def! { env list -- val }
  73     list MalList/start @ cell+ { arg0 }
  74     arg0 @ ( key )
  75     env arg0 cell+ @ eval dup { val } ( key val )
  76     env env/set val ;;
  77
  78 defspecial let* { old-env list -- val }
  79     old-env MalEnv. { env }
  80     list MalList/start @ cell+ dup { arg0 }
  81     @ to-list
  82     dup MalList/start @ { bindings-start } ( list )
  83     MalList/count @ 0 +do
  84         bindings-start i cells + dup @ swap cell+ @ ( sym expr )
  85         env swap eval
  86         env env/set
  87     2 +loop
  88     env arg0 cell+ @ TCO-eval
  89     \ TODO: dec refcount of env
  90     ;;
  91
  92 defspecial do { env list -- val }
  93     list MalList/start @ { start }
  94     list MalList/count @ dup 1- { last } 1 ?do
  95         env   start i cells + @
  96         i last = if
  97             TCO-eval
  98         else
  99             eval drop
 100         endif
 101     loop ;;
 102
 103 defspecial if { env list -- val }
 104     list MalList/start @ cell+ { arg0 }
 105     env arg0 @ eval ( test-val )
 106     dup mal-false = if
 107         drop -1
 108     else
 109         mal-nil =
 110     endif
 111     if
 112         \ branch to false
 113         list MalList/count @ 3 > if
 114             env arg0 cell+ cell+ @ TCO-eval
 115         else
 116             mal-nil
 117         endif
 118     else
 119         \ branch to true
 120         env arg0 cell+ @ TCO-eval
 121     endif ;;
 122
 123 s" &" MalSymbol. constant &-sym
 124
 125 MalUserFn
 126   extend eval-invoke { call-env list mal-fn -- list }
 127     call-env list eval-rest { argv argc }
 128
 129     mal-fn MalUserFn/formal-args @ { f-args-list }
 130     mal-fn MalUserFn/env @ MalEnv. { env }
 131
 132     f-args-list MalList/start @ { f-args }
 133     f-args-list MalList/count @ ?dup 0= if else
 134         \ pass empty list for last arg, unless overridden below
 135         1- cells f-args + @ MalList new env env/set
 136     endif
 137     argc 0 ?do
 138         f-args i cells + @
 139         dup &-sym m= if
 140             drop
 141             f-args i 1+ cells + @ ( more-args-symbol )
 142             MalList new ( sym more-args )
 143             argc i - dup { c } over MalList/count !
 144             c cells allocate throw dup { start } over MalList/start !
 145             argv i cells +  start  c cells  cmove
 146             env env/set
 147             leave
 148         endif
 149         argv i cells + @
 150         env env/set
 151     loop
 152
 153     env   mal-fn MalUserFn/body @   TCO-eval ;;
 154 drop
 155
 156 defspecial fn* { env list -- val }
 157     list MalList/start @ cell+ { arg0 }
 158     MalUserFn new
 159     env over MalUserFn/env !
 160     arg0 @ to-list over MalUserFn/formal-args !
 161     arg0 cell+ @ over MalUserFn/body ! ;;
 162
 163 MalSymbol
 164   extend mal-eval { env sym -- val }
 165     sym env env/get-addr
 166     dup 0= if
 167         drop
 168         0 0 s" ' not found" sym pr-str s" '" ...throw-str
 169     else
 170         @
 171     endif ;;
 172 drop
 173
 174 : eval-ast { env list -- list }
 175     here
 176     list MalList/start @ { expr-start }
 177     list MalList/count @ 0 ?do
 178         env expr-start i cells + @ eval ,
 179     loop
 180     here>MalList ;
 181
 182 MalList
 183   extend mal-eval { env list -- val }
 184     list MalList/count @ 0= if
 185         list
 186     else
 187         env list MalList/start @ @ eval
 188         env list rot eval-invoke
 189     endif ;;
 190 drop
 191
 192 MalVector
 193   extend mal-eval ( env vector -- vector )
 194     MalVector/list @ eval-ast
 195     MalVector new swap over MalVector/list ! ;;
 196 drop
 197
 198 MalMap
 199   extend mal-eval ( env map -- map )
 200     MalMap/list @ eval-ast
 201     MalMap new swap over MalMap/list ! ;;
 202 drop
 203
 204 : rep ( str-addr str-len -- str-addr str-len )
 205     read
 206     repl-env swap eval
 207     print ;
 208
 209 create buff 128 allot
 210 77777777777 constant stack-leak-detect
 211
 212 s\" (def! not (fn* (x) (if x false true)))" rep 2drop
 213
 214 : read-lines
 215     begin
 216       ." user> "
 217       stack-leak-detect
 218       buff 128 stdin read-line throw
 219     while ( num-bytes-read )
 220       dup 0 <> if
 221         buff swap ( str-addr str-len )
 222         ['] rep
 223         \ execute ['] nop \ uncomment to see stack traces
 224         catch ?dup 0= if
 225             safe-type cr
 226             stack-leak-detect <> if ." --stack leak--" cr endif
 227         else { errno }
 228             begin stack-leak-detect = until
 229             errno 1 <> if
 230                 s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
 231                 to exception-object
 232             endif
 233             ." Uncaught exception: "
 234             exception-object pr-str safe-type cr
 235         endif
 236       endif
 237     repeat ;
 238
 239 read-lines
 240 cr
 241 bye