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