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