forth/step9_try.fs

   1 require reader.fs
   2 require printer.fs
   3 require core.fs
   4
   5 core MalEnv. constant repl-env
   6
   7 \ Fully evalutate any Mal object:
   8 \ def-protocol-method mal-eval ( env ast -- val )
   9
  10 \ Invoke an object, given whole env and unevaluated argument forms:
  11 \ def-protocol-method eval-invoke ( env list obj -- ... )
  12
  13 \ Invoke a function, given parameter values
  14 \ def-protocol-method invoke ( argv argc mal-fn -- ... )
  15
  16 99999999 constant TCO-eval
  17
  18 : read read-str ;
  19 : eval ( env obj )
  20     begin
  21         \ ." eval-> " dup pr-str safe-type cr
  22         mal-eval
  23         dup TCO-eval =
  24     while
  25         drop
  26     repeat ;
  27 : print
  28     \ ." Type: " dup mal-type @ type-name safe-type cr
  29     pr-str ;
  30
  31 MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
  32
  33 MalKeyword
  34   extend eval-invoke { env list kw -- val }
  35     0   kw   env list MalList/start @ cell+ @ eval   get
  36     ?dup 0= if
  37         \ compute not-found value
  38         list MalList/count @ 1 > if
  39             env  list MalList/start @ 2 cells + @  TCO-eval
  40         else
  41             mal-nil
  42         endif
  43     endif ;;
  44   extend invoke { argv argc kw -- val }
  45     0   kw   argv @   get
  46     ?dup 0= if
  47         argc 1 > if
  48             argv cell+ @
  49         else
  50             mal-nil
  51         endif
  52     endif ;;
  53 drop
  54
  55 \ eval all but the first item of list
  56 : eval-rest { env list -- argv argc }
  57     list MalList/start @ cell+ { expr-start }
  58     list MalList/count @ 1- { argc }
  59     argc cells allocate throw { target }
  60     argc 0 ?do
  61         env expr-start i cells + @ eval
  62         target i cells + !
  63     loop
  64     target argc ;
  65
  66 MalNativeFn
  67   extend eval-invoke { env list this -- list }
  68     env list eval-rest ( argv argc )
  69     this invoke ;;
  70   extend invoke ( argv argc this -- val )
  71     MalNativeFn/xt @ execute ;;
  72 drop
  73
  74 SpecialOp
  75   extend eval-invoke ( env list this -- list )
  76     SpecialOp/xt @ execute ;;
  77 drop
  78
  79 : install-special ( symbol xt )
  80     SpecialOp. repl-env env/set ;
  81
  82 : defspecial
  83     parse-allot-name MalSymbol.
  84     ['] install-special
  85     :noname
  86     ;
  87
  88 : is-pair? ( obj -- bool )
  89     empty? mal-false = ;
  90
  91 defspecial quote ( env list -- form )
  92     nip MalList/start @ cell+ @ ;;
  93
  94 s" concat" MalSymbol. constant concat-sym
  95 s" cons" MalSymbol. constant cons-sym
  96
  97 defer quasiquote
  98 : quasiquote0 { ast -- form }
  99     ast is-pair? 0= if
 100         here quote-sym , ast , here>MalList
 101     else
 102         ast to-list MalList/start @ { ast-start }
 103         ast-start @ { ast[0] }
 104         ast[0] unquote-sym m= if
 105             ast-start cell+ @
 106         else
 107             ast[0] is-pair? if
 108                 ast[0] to-list MalList/start @ { ast[0]-start }
 109                 ast[0]-start @ splice-unquote-sym m= if
 110                     here
 111                     concat-sym ,
 112                     ast[0]-start cell+ @ ,
 113                     ast to-list MalList/rest quasiquote ,
 114                     here>MalList
 115                     false
 116                 else true endif
 117             else true endif
 118             if
 119                 here
 120                 cons-sym ,
 121                 ast[0] quasiquote ,
 122                 ast to-list MalList/rest quasiquote ,
 123                 here>MalList
 124             endif
 125         endif
 126     endif ;
 127 ' quasiquote0 is quasiquote
 128
 129 defspecial quasiquote ( env list )
 130     MalList/start @ cell+ @ ( ast )
 131     quasiquote TCO-eval ;;
 132
 133 defspecial def! { env list -- val }
 134     list MalList/start @ cell+ { arg0 }
 135     arg0 @ ( key )
 136     env arg0 cell+ @ eval dup { val } ( key val )
 137     env env/set val ;;
 138
 139 defspecial defmacro! { env list -- val }
 140     list MalList/start @ cell+ { arg0 }
 141     arg0 @ ( key )
 142     env arg0 cell+ @ eval { val }
 143     true val MalUserFn/is-macro? !
 144     val env env/set
 145     val ;;
 146
 147 defspecial let* { old-env list -- val }
 148     old-env MalEnv. { env }
 149     list MalList/start @ cell+ dup { arg0 }
 150     @ to-list
 151     dup MalList/start @ { bindings-start } ( list )
 152     MalList/count @ 0 +do
 153         bindings-start i cells + dup @ swap cell+ @ ( sym expr )
 154         env swap eval
 155         env env/set
 156     2 +loop
 157     env arg0 cell+ @ TCO-eval
 158     \ TODO: dec refcount of env
 159     ;;
 160
 161 defspecial do { env list -- val }
 162     list MalList/start @ { start }
 163     list MalList/count @ dup 1- { last } 1 ?do
 164         env   start i cells + @
 165         i last = if
 166             TCO-eval
 167         else
 168             eval drop
 169         endif
 170     loop ;;
 171
 172 defspecial if { env list -- val }
 173     list MalList/start @ cell+ { arg0 }
 174     env arg0 @ eval ( test-val )
 175     dup mal-false = if
 176         drop -1
 177     else
 178         mal-nil =
 179     endif
 180     if
 181         \ branch to false
 182         list MalList/count @ 3 > if
 183             env arg0 cell+ cell+ @ TCO-eval
 184         else
 185             mal-nil
 186         endif
 187     else
 188         \ branch to true
 189         env arg0 cell+ @ TCO-eval
 190     endif ;;
 191
 192 s" &" MalSymbol. constant &-sym
 193
 194 : new-user-fn-env { argv argc mal-fn -- env }
 195     mal-fn MalUserFn/formal-args @ { f-args-list }
 196     mal-fn MalUserFn/env @ MalEnv. { env }
 197
 198     f-args-list MalList/start @ { f-args }
 199     f-args-list MalList/count @ ?dup 0= if else
 200         \ pass nil for last arg, unless overridden below
 201         1- cells f-args + @ mal-nil env env/set
 202     endif
 203     argc 0 ?do
 204         f-args i cells + @
 205         dup &-sym m= if
 206             drop
 207             argc i - { c }
 208             c cells allocate throw { start }
 209             argv i cells +  start  c cells  cmove
 210             f-args i 1+ cells + @ ( more-args-symbol )
 211             start c MalList. env env/set
 212             leave
 213         endif
 214         argv i cells + @
 215         env env/set
 216     loop
 217     env ;
 218
 219 MalUserFn
 220   extend eval-invoke { call-env list mal-fn -- list }
 221     mal-fn MalUserFn/is-macro? @ if
 222         list MalList/start @ cell+  list MalList/count @ 1-
 223     else
 224         call-env list eval-rest
 225     endif
 226     mal-fn invoke ;;
 227
 228   extend invoke ( argv argc mal-fn )
 229     dup { mal-fn } new-user-fn-env { env }
 230
 231     mal-fn MalUserFn/is-macro? @ if
 232         env   mal-fn MalUserFn/body @   eval
 233         env swap TCO-eval
 234     else
 235         env   mal-fn MalUserFn/body @   TCO-eval
 236     endif ;;
 237 drop
 238
 239 defspecial fn* { env list -- val }
 240     list MalList/start @ cell+ { arg0 }
 241     MalUserFn new
 242     false over MalUserFn/is-macro? !
 243     env over MalUserFn/env !
 244     arg0 @ to-list over MalUserFn/formal-args !
 245     arg0 cell+ @ over MalUserFn/body ! ;;
 246
 247 defspecial macroexpand ( env list[_,form] -- form )
 248     MalList/start @ cell+ @ swap over ( form env form )
 249     MalList/start @ @ ( form env macro-name-expr )
 250     eval { macro-fn } ( form )
 251     dup MalList/start @ cell+  swap MalList/count @ 1- macro-fn ( argv argc fn )
 252     new-user-fn-env ( env )
 253     macro-fn MalUserFn/body @   TCO-eval ;;
 254
 255 5555555555 constant pre-try
 256
 257 defspecial try* { env list -- val }
 258     list MalList/start @ cell+ { arg0 }
 259     pre-try
 260     env arg0 @ ['] eval catch ?dup 0= if
 261         nip
 262     else { errno }
 263         begin pre-try = until
 264         errno 1 <> if
 265             s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
 266             to exception-object
 267         endif
 268         arg0 cell+ @ ( list[catch*,sym,form] )
 269         MalList/start @ cell+ { catch0 }
 270         env MalEnv. { catch-env }
 271         catch0 @ exception-object catch-env env/set
 272         catch-env  catch0 cell+ @  TCO-eval
 273     endif ;;
 274
 275 MalSymbol
 276   extend mal-eval { env sym -- val }
 277     0 sym env get
 278     dup 0= if
 279         drop
 280         0 0 s" ' not found" sym as-native s" '" ...throw-str
 281     endif ;;
 282 drop
 283
 284 : eval-ast { env list -- list }
 285     here
 286     list MalList/start @ { expr-start }
 287     list MalList/count @ 0 ?do
 288         env expr-start i cells + @ eval ,
 289     loop
 290     here>MalList ;
 291
 292 MalList
 293   extend mal-eval { env list -- val }
 294     env list MalList/start @ @ eval
 295     env list rot eval-invoke ;;
 296 drop
 297
 298 MalVector
 299   extend mal-eval ( env vector -- vector )
 300     MalVector/list @ eval-ast
 301     MalVector new swap over MalVector/list ! ;;
 302 drop
 303
 304 MalMap
 305   extend mal-eval ( env map -- map )
 306     MalMap/list @ eval-ast
 307     MalMap new swap over MalMap/list ! ;;
 308 drop
 309
 310 defcore eval ( argv argc )
 311   drop @ repl-env swap eval ;;
 312
 313 : rep ( str-addr str-len -- val )
 314     read
 315     repl-env swap eval
 316     print ;
 317
 318 : mk-args-list ( -- )
 319     here
 320     begin
 321         next-arg 2dup 0 0 d<> while
 322             MalString. ,
 323     repeat
 324     2drop here>MalList ;
 325
 326 create buff 128 allot
 327 77777777777 constant stack-leak-detect
 328
 329 : nop ;
 330
 331 defcore map ( argv argc -- list )
 332     drop dup @ swap cell+ @ to-list { fn list }
 333     here
 334     list MalList/start @   list MalList/count @  cells   over + swap   +do
 335         i 1 fn invoke
 336         dup TCO-eval = if drop eval endif
 337         ,
 338     cell +loop
 339     here>MalList ;;
 340
 341 defcore readline ( argv argc -- mal-string )
 342     drop @ unpack-str type
 343     buff 128 stdin read-line throw
 344     if buff swap MalString. else mal-nil endif ;;
 345
 346 s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
 347 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
 348 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
 349 s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep drop
 350
 351 : repl ( -- )
 352     begin
 353       ." user> "
 354       stack-leak-detect
 355       buff 128 stdin read-line throw
 356     while ( num-bytes-read )
 357       buff swap ( str-addr str-len )
 358       ['] rep
 359       execute ['] nop \ uncomment to see stack traces
 360       catch ?dup 0= if
 361           safe-type cr
 362           stack-leak-detect <> if ." --stack leak--" cr endif
 363       else { errno }
 364           begin stack-leak-detect = until
 365           errno 1 <> if
 366               s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
 367               to exception-object
 368           endif
 369           ." Uncaught exception: "
 370           exception-object pr-str safe-type cr
 371       endif
 372     repeat ;
 373
 374 : main ( -- )
 375     mk-args-list { args-list }
 376     args-list MalList/count @ 0= if
 377         s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
 378         repl
 379     else
 380         args-list MalList/start @ @ { filename }
 381         s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set
 382
 383         repl-env
 384         here s" load-file" MalSymbol. , filename , here>MalList
 385         eval print
 386     endif ;
 387
 388 main
 389 cr
 390 bye
 391
 392 4