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         0 0 s" ' not found" sym pr-str s" '" ...throw-str
 216     else
 217         @
 218     endif ;;
 219 drop
 220
 221 : eval-ast { env list -- list }
 222     here
 223     list MalList/start @ { expr-start }
 224     list MalList/count @ 0 ?do
 225         env expr-start i cells + @ eval ,
 226     loop
 227     here>MalList ;
 228
 229 MalList
 230   extend mal-eval { env list -- val }
 231     list MalList/count @ 0= if
 232         list
 233     else
 234         env list MalList/start @ @ eval
 235         env list rot eval-invoke
 236     endif ;;
 237 drop
 238
 239 MalVector
 240   extend mal-eval ( env vector -- vector )
 241     MalVector/list @ eval-ast
 242     MalVector new swap over MalVector/list ! ;;
 243 drop
 244
 245 MalMap
 246   extend mal-eval ( env map -- map )
 247     MalMap/list @ eval-ast
 248     MalMap new swap over MalMap/list ! ;;
 249 drop
 250
 251 defcore eval ( argv argc )
 252   drop @ repl-env swap eval ;;
 253
 254 : rep ( str-addr str-len -- str-addr str-len )
 255     read
 256     repl-env swap eval
 257     print ;
 258
 259 : mk-args-list ( -- )
 260     here
 261     begin
 262         next-arg 2dup 0 0 d<> while
 263             MalString. ,
 264     repeat
 265     2drop here>MalList ;
 266
 267 create buff 128 allot
 268 77777777777 constant stack-leak-detect
 269
 270 : nop ;
 271
 272 defcore swap! { argv argc -- val }
 273     \ argv is  (atom fn args...)
 274     argv @ { atom }
 275     argv cell+ @ { fn }
 276     argc 1- { call-argc }
 277     call-argc cells allocate throw { call-argv }
 278     atom Atom/val   call-argv    1 cells   cmove
 279     argv cell+ cell+   call-argv cell+   call-argc 1- cells   cmove
 280     call-argv call-argc fn  invoke
 281     dup TCO-eval = if drop eval endif { new-val }
 282     new-val atom Atom/val !
 283     new-val ;;
 284
 285 s\" (def! not (fn* (x) (if x false true)))" rep 2drop
 286 s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))" rep 2drop
 287
 288 : repl ( -- )
 289     begin
 290       ." user> "
 291       stack-leak-detect
 292       buff 128 stdin read-line throw
 293     while ( num-bytes-read )
 294       dup 0 <> if
 295         buff swap ( str-addr str-len )
 296         ['] rep
 297         \ execute ['] nop \ uncomment to see stack traces
 298         catch ?dup 0= if
 299             safe-type cr
 300             stack-leak-detect <> if ." --stack leak--" cr endif
 301         else { errno }
 302             begin stack-leak-detect = until
 303             errno 1 <> if
 304                 s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
 305                 to exception-object
 306             endif
 307             ." Uncaught exception: "
 308             exception-object pr-str safe-type cr
 309         endif
 310       endif
 311     repeat ;
 312
 313 : main ( -- )
 314     mk-args-list { args-list }
 315     args-list MalList/count @ 0= if
 316         s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
 317         repl
 318     else
 319         args-list MalList/start @ @ { filename }
 320         s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set
 321
 322         repl-env
 323         here s" load-file" MalSymbol. , filename , here>MalList
 324         eval print
 325     endif ;
 326
 327 main
 328 cr
 329 bye