forth/step6_file.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     env list eval-rest ( argv argc )
  51     this invoke ;;
  52   extend invoke ( argv argc this -- val )
  53     MalNativeFn/xt @ execute ;;
  54 drop
  55
  56 SpecialOp
  57   extend eval-invoke ( env list this -- list )
  58     SpecialOp/xt @ execute ;;
  59 drop
  60
  61 : install-special ( symbol xt )
  62     SpecialOp. repl-env env/set ;
  63
  64 : defspecial
  65     parse-allot-name MalSymbol.
  66     ['] install-special
  67     :noname
  68     ;
  69
  70 defspecial quote ( env list -- form )
  71     nip MalList/start @ cell+ @ ;;
  72
  73 defspecial def! { env list -- val }
  74     list MalList/start @ cell+ { arg0 }
  75     arg0 @ ( key )
  76     env arg0 cell+ @ eval dup { val } ( key val )
  77     env env/set val ;;
  78
  79 defspecial let* { old-env list -- val }
  80     old-env MalEnv. { env }
  81     list MalList/start @ cell+ dup { arg0 }
  82     @ to-list
  83     dup MalList/start @ { bindings-start } ( list )
  84     MalList/count @ 0 +do
  85         bindings-start i cells + dup @ swap cell+ @ ( sym expr )
  86         env swap eval
  87         env env/set
  88     2 +loop
  89     env arg0 cell+ @ TCO-eval
  90     \ TODO: dec refcount of env
  91     ;;
  92
  93 defspecial do { env list -- val }
  94     list MalList/start @ { start }
  95     list MalList/count @ dup 1- { last } 1 ?do
  96         env   start i cells + @
  97         i last = if
  98             TCO-eval
  99         else
 100             eval drop
 101         endif
 102     loop ;;
 103
 104 defspecial if { env list -- val }
 105     list MalList/start @ cell+ { arg0 }
 106     env arg0 @ eval ( test-val )
 107     dup mal-false = if
 108         drop -1
 109     else
 110         mal-nil =
 111     endif
 112     if
 113         \ branch to false
 114         list MalList/count @ 3 > if
 115             env arg0 cell+ cell+ @ TCO-eval
 116         else
 117             mal-nil
 118         endif
 119     else
 120         \ branch to true
 121         env arg0 cell+ @ TCO-eval
 122     endif ;;
 123
 124 s" &" MalSymbol. constant &-sym
 125
 126 : new-user-fn-env { argv argc mal-fn -- env }
 127     mal-fn MalUserFn/formal-args @ { f-args-list }
 128     mal-fn MalUserFn/env @ MalEnv. { env }
 129
 130     f-args-list MalList/start @ { f-args }
 131     f-args-list MalList/count @ ?dup 0= if else
 132         \ pass nil for last arg, unless overridden below
 133         1- cells f-args + @ mal-nil env env/set
 134     endif
 135     argc 0 ?do
 136         f-args i cells + @
 137         dup &-sym m= if
 138             drop
 139             argc i - { c }
 140             c cells allocate throw { start }
 141             argv i cells +  start  c cells  cmove
 142             f-args i 1+ cells + @ ( more-args-symbol )
 143             start c MalList. env env/set
 144             leave
 145         endif
 146         argv i cells + @
 147         env env/set
 148     loop
 149     env ;
 150
 151 MalUserFn
 152   extend eval-invoke { call-env list mal-fn -- list }
 153     call-env list eval-rest
 154     mal-fn invoke ;;
 155
 156   extend invoke ( argv argc mal-fn )
 157     dup { mal-fn } new-user-fn-env { env }
 158     env   mal-fn MalUserFn/body @   TCO-eval ;;
 159 drop
 160
 161 defspecial fn* { env list -- val }
 162     list MalList/start @ cell+ { arg0 }
 163     MalUserFn new
 164     env over MalUserFn/env !
 165     arg0 @ to-list over MalUserFn/formal-args !
 166     arg0 cell+ @ over MalUserFn/body ! ;;
 167
 168 MalSymbol
 169   extend mal-eval { env sym -- val }
 170     sym env env/get-addr
 171     dup 0= if
 172         drop
 173         ." Symbol '" sym pr-str safe-type ." ' not found." cr
 174         1 throw
 175     else
 176         @
 177     endif ;;
 178 drop
 179
 180 : eval-ast { env list -- list }
 181     here
 182     list MalList/start @ { expr-start }
 183     list MalList/count @ 0 ?do
 184         env expr-start i cells + @ eval ,
 185     loop
 186     here>MalList ;
 187
 188 MalList
 189   extend mal-eval { env list -- val }
 190     env list MalList/start @ @ eval
 191     env list rot eval-invoke ;;
 192 drop
 193
 194 MalVector
 195   extend mal-eval ( env vector -- vector )
 196     MalVector/list @ eval-ast
 197     MalVector new swap over MalVector/list ! ;;
 198 drop
 199
 200 MalMap
 201   extend mal-eval ( env map -- map )
 202     MalMap/list @ eval-ast
 203     MalMap new swap over MalMap/list ! ;;
 204 drop
 205
 206 defcore eval ( argv argc )
 207   drop @ repl-env swap eval ;;
 208
 209 : rep ( str-addr str-len -- str-addr str-len )
 210     read
 211     repl-env swap eval
 212     print ;
 213
 214 : mk-args-list ( -- )
 215     here
 216     begin
 217         next-arg 2dup 0 0 d<> while
 218             MalString. ,
 219     repeat
 220     2drop here>MalList ;
 221
 222 create buff 128 allot
 223 77777777777 constant stack-leak-detect
 224
 225 : nop ;
 226
 227 defcore swap! { argv argc -- val }
 228     \ argv is  (atom fn args...)
 229     argv @ { atom }
 230     argv cell+ @ { fn }
 231     argc 1- { call-argc }
 232     call-argc cells allocate throw { call-argv }
 233     atom Atom/val   call-argv    1 cells   cmove
 234     argv cell+ cell+   call-argv cell+   call-argc 1- cells   cmove
 235     call-argv call-argc fn  invoke
 236     dup TCO-eval = if drop eval endif { new-val }
 237     new-val atom Atom/val !
 238     new-val ;;
 239
 240 s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop
 241
 242 : repl ( -- )
 243     begin
 244       ." user> "
 245       stack-leak-detect
 246       buff 128 stdin read-line throw
 247     while ( num-bytes-read )
 248       buff swap ( str-addr str-len )
 249       ['] rep
 250       \ execute type
 251       catch ?dup 0= if safe-type else ." Caught error " . endif
 252       cr
 253       stack-leak-detect <> if ." --stack leak--" cr endif
 254     repeat ;
 255
 256 : main ( -- )
 257     mk-args-list { args-list }
 258     args-list MalList/count @ 0= if
 259         s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
 260         repl
 261     else
 262         args-list MalList/start @ @ { filename }
 263         s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set
 264
 265         repl-env
 266         here s" load-file" MalSymbol. , filename , here>MalList
 267         eval print
 268     endif ;
 269
 270 main
 271 cr
 272 bye