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