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 defspecial . { env coll -- rtn-list }
 265     depth { old-depth }
 266     coll to-list dup MalList/count @ swap MalList/start @ { count start }
 267     count cells start +  start cell+  +do
 268         env i @ eval as-native
 269     cell +loop ;;
 270
 271 MalSymbol
 272   extend mal-eval { env sym -- val }
 273     sym env env/get-addr
 274     dup 0= if
 275         drop
 276         0 0 s" ' not found" sym as-native s" '" ...throw-str
 277     else
 278         @
 279     endif ;;
 280 drop
 281
 282 : eval-ast { env list -- list }
 283     here
 284     list MalList/start @ { expr-start }
 285     list MalList/count @ 0 ?do
 286         env expr-start i cells + @ eval ,
 287     loop
 288     here>MalList ;
 289
 290 MalList
 291   extend mal-eval { env list -- val }
 292     env list MalList/start @ @ eval
 293     env list rot eval-invoke ;;
 294 drop
 295
 296 MalVector
 297   extend mal-eval ( env vector -- vector )
 298     MalVector/list @ eval-ast
 299     MalVector new swap over MalVector/list ! ;;
 300 drop
 301
 302 MalMap
 303   extend mal-eval ( env map -- map )
 304     MalMap/list @ eval-ast
 305     MalMap new swap over MalMap/list ! ;;
 306 drop
 307
 308 defcore eval ( argv argc )
 309   drop @ repl-env swap eval ;;
 310
 311 : rep ( str-addr str-len -- str-addr str-len )
 312     read
 313     repl-env swap eval
 314     print ;
 315
 316 : mk-args-list ( -- )
 317     here
 318     begin
 319         next-arg 2dup 0 0 d<> while
 320             MalString. ,
 321     repeat
 322     2drop here>MalList ;
 323
 324 create buff 128 allot
 325 77777777777 constant stack-leak-detect
 326
 327 : nop ;
 328
 329 defcore map ( argv argc -- list )
 330     drop dup @ swap cell+ @ to-list { fn list }
 331     here
 332     list MalList/start @   list MalList/count @  cells   over + swap   +do
 333         i 1 fn invoke
 334         dup TCO-eval = if drop eval endif
 335         ,
 336     cell +loop
 337     here>MalList ;;
 338
 339 defcore readline ( argv argc -- mal-string )
 340     drop @ unpack-str type stdout flush-file drop
 341     buff 128 stdin read-line throw
 342     if buff swap MalString. else drop mal-nil endif ;;
 343
 344 s\" (def! *host-language* \"forth\")" rep 2drop
 345 s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop
 346 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
 347 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
 348 s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep 2drop
 349
 350 : repl ( -- )
 351     s\" (println (str \"Mal [\" *host-language* \"]\"))" rep 2drop
 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