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