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 empty list for last arg, unless overridden below
 133         1- cells f-args + @ MalList new 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         0 0 s" ' not found" sym pr-str s" '" ...throw-str
 174     else
 175         @
 176     endif ;;
 177 drop
 178
 179 : eval-ast { env list -- list }
 180     here
 181     list MalList/start @ { expr-start }
 182     list MalList/count @ 0 ?do
 183         env expr-start i cells + @ eval ,
 184     loop
 185     here>MalList ;
 186
 187 MalList
 188   extend mal-eval { env list -- val }
 189     list MalList/count @ 0= if
 190         list
 191     else
 192         env list MalList/start @ @ eval
 193         env list rot eval-invoke
 194     endif ;;
 195 drop
 196
 197 MalVector
 198   extend mal-eval ( env vector -- vector )
 199     MalVector/list @ eval-ast
 200     MalVector new swap over MalVector/list ! ;;
 201 drop
 202
 203 MalMap
 204   extend mal-eval ( env map -- map )
 205     MalMap/list @ eval-ast
 206     MalMap new swap over MalMap/list ! ;;
 207 drop
 208
 209 defcore eval ( argv argc )
 210   drop @ repl-env swap eval ;;
 211
 212 : rep ( str-addr str-len -- str-addr str-len )
 213     read
 214     repl-env swap eval
 215     print ;
 216
 217 : mk-args-list ( -- )
 218     here
 219     begin
 220         next-arg 2dup 0 0 d<> while
 221             MalString. ,
 222     repeat
 223     2drop here>MalList ;
 224
 225 create buff 128 allot
 226 77777777777 constant stack-leak-detect
 227
 228 : nop ;
 229
 230 defcore swap! { argv argc -- val }
 231     \ argv is  (atom fn args...)
 232     argv @ { atom }
 233     argv cell+ @ { fn }
 234     argc 1- { call-argc }
 235     call-argc cells allocate throw { call-argv }
 236     atom Atom/val   call-argv    1 cells   cmove
 237     argv cell+ cell+   call-argv cell+   call-argc 1- cells   cmove
 238     call-argv call-argc fn  invoke
 239     dup TCO-eval = if drop eval endif { new-val }
 240     new-val atom Atom/val !
 241     new-val ;;
 242
 243 s\" (def! not (fn* (x) (if x false true)))" rep 2drop
 244 s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" rep 2drop
 245
 246 : repl ( -- )
 247     begin
 248       ." user> "
 249       stack-leak-detect
 250       buff 128 stdin read-line throw
 251     while ( num-bytes-read )
 252       dup 0 <> if
 253         buff swap ( str-addr str-len )
 254         ['] rep
 255         \ execute ['] nop \ uncomment to see stack traces
 256         catch ?dup 0= if
 257             safe-type cr
 258             stack-leak-detect <> if ." --stack leak--" cr endif
 259         else { errno }
 260             begin stack-leak-detect = until
 261             errno 1 <> if
 262                 s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
 263                 to exception-object
 264             endif
 265             ." Uncaught exception: "
 266             exception-object pr-str safe-type cr
 267         endif
 268       endif
 269     repeat ;
 270
 271 : main ( -- )
 272     mk-args-list { args-list }
 273     args-list MalList/count @ 0= if
 274         s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
 275         repl
 276     else
 277         args-list MalList/start @ @ { filename }
 278         s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set
 279
 280         repl-env
 281         here s" load-file" MalSymbol. , filename , here>MalList
 282         eval print
 283     endif ;
 284
 285 main
 286 cr
 287 bye