forth/step4_if_fn_do.fs

   1 require reader.fs
   2 require printer.fs
   3 require core.fs
   4
   5 core MalEnv. constant repl-env
   6
   7 : read read-str ;
   8 : eval ( env obj ) mal-eval ;
   9 : print
  10     \ ." Type: " dup mal-type @ type-name safe-type cr
  11     pr-str ;
  12
  13 MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
  14
  15 MalKeyword
  16   extend eval-invoke { env list kw -- val }
  17     0   kw   env list MalList/start @ cell+ @ eval   get
  18     ?dup 0= if
  19         \ compute not-found value
  20         list MalList/count @ 1 > if
  21             env  list MalList/start @ 2 cells + @  eval
  22         else
  23             mal-nil
  24         endif
  25     endif ;;
  26 drop
  27
  28 \ eval all but the first item of list
  29 : eval-rest { env list -- argv argc }
  30     list MalList/start @ cell+ { expr-start }
  31     list MalList/count @ 1- { argc }
  32     argc cells allocate throw { target }
  33     argc 0 ?do
  34         env expr-start i cells + @ eval
  35         target i cells + !
  36     loop
  37     target argc ;
  38
  39 MalNativeFn
  40   extend eval-invoke ( env list this -- list )
  41     MalNativeFn/xt @ { xt }
  42     eval-rest ( argv argc )
  43     xt execute ( return-val ) ;;
  44 drop
  45
  46 SpecialOp
  47   extend eval-invoke ( env list this -- list )
  48     SpecialOp/xt @ execute ;;
  49 drop
  50
  51 : install-special ( symbol xt )
  52     SpecialOp. repl-env env/set ;
  53
  54 : defspecial
  55     parse-allot-name MalSymbol.
  56     ['] install-special
  57     :noname
  58     ;
  59
  60 defspecial quote ( env list -- form )
  61     nip MalList/start @ cell+ @ ;;
  62
  63 defspecial def! { env list -- val }
  64     list MalList/start @ cell+ { arg0 }
  65     arg0 @ ( key )
  66     env arg0 cell+ @ eval dup { val } ( key val )
  67     env env/set val ;;
  68
  69 defspecial let* { old-env list -- val }
  70     old-env MalEnv. { env }
  71     list MalList/start @ cell+ dup { arg0 }
  72     @ to-list
  73     dup MalList/start @ { bindings-start } ( list )
  74     MalList/count @ 0 +do
  75         bindings-start i cells + dup @ swap cell+ @ ( sym expr )
  76         env swap eval
  77         env env/set
  78     2 +loop
  79     env arg0 cell+ @ eval
  80     \ TODO: dec refcount of env
  81     ;;
  82
  83 defspecial do { env list -- val }
  84     list MalList/start @
  85     0
  86     list MalList/count @ 1 ?do
  87         drop
  88         dup i cells + @ env swap eval
  89     loop
  90     nip ;;
  91
  92 defspecial if { env list -- val }
  93     list MalList/start @ cell+ { arg0 }
  94     env arg0 @ eval ( test-val )
  95     dup mal-false = if
  96         drop -1
  97     else
  98         mal-nil =
  99     endif
 100     if
 101         \ branch to false
 102         list MalList/count @ 3 > if
 103             env arg0 cell+ cell+ @ eval
 104         else
 105             mal-nil
 106         endif
 107     else
 108         \ branch to true
 109         env arg0 cell+ @ eval
 110     endif ;;
 111
 112 s" &" MalSymbol. constant &-sym
 113
 114 MalUserFn
 115   extend eval-invoke { call-env list mal-fn -- list }
 116     call-env list eval-rest { argv argc }
 117
 118     mal-fn MalUserFn/formal-args @ { f-args-list }
 119     mal-fn MalUserFn/env @ MalEnv. { env }
 120
 121     f-args-list MalList/start @ { f-args }
 122     f-args-list MalList/count @ ?dup 0= if else
 123         \ pass empty list for last arg, unless overridden below
 124         1- cells f-args + @ MalList new env env/set
 125     endif
 126     argc 0 ?do
 127         f-args i cells + @
 128         dup &-sym m= if
 129             drop
 130             f-args i 1+ cells + @ ( more-args-symbol )
 131             MalList new ( sym more-args )
 132             argc i - dup { c } over MalList/count !
 133             c cells allocate throw dup { start } over MalList/start !
 134             argv i cells +  start  c cells  cmove
 135             env env/set
 136             leave
 137         endif
 138         argv i cells + @
 139         env env/set
 140     loop
 141
 142     env   mal-fn MalUserFn/body @   eval ;;
 143 drop
 144
 145 defspecial fn* { env list -- val }
 146     list MalList/start @ cell+ { arg0 }
 147     MalUserFn new
 148     env over MalUserFn/env !
 149     arg0 @ to-list over MalUserFn/formal-args !
 150     arg0 cell+ @ over MalUserFn/body ! ;;
 151
 152 MalSymbol
 153   extend mal-eval { env sym -- val }
 154     sym env env/get-addr
 155     dup 0= if
 156         drop
 157         ." Symbol '" sym pr-str safe-type ." ' not found." cr
 158         1 throw
 159     else
 160         @
 161     endif ;;
 162 drop
 163
 164 : eval-ast { env list -- list }
 165     here
 166     list MalList/start @ { expr-start }
 167     list MalList/count @ 0 ?do
 168         env expr-start i cells + @ eval ,
 169     loop
 170     here>MalList ;
 171
 172 MalList
 173   extend mal-eval { env list -- val }
 174     list MalList/count @ 0= if
 175         list
 176     else
 177         env list MalList/start @ @ eval
 178         env list rot eval-invoke
 179     endif ;;
 180 drop
 181
 182 MalVector
 183   extend mal-eval ( env vector -- vector )
 184     MalVector/list @ eval-ast
 185     MalVector new swap over MalVector/list ! ;;
 186 drop
 187
 188 MalMap
 189   extend mal-eval ( env map -- map )
 190     MalMap/list @ eval-ast
 191     MalMap new swap over MalMap/list ! ;;
 192 drop
 193
 194 : rep ( str-addr str-len -- str-addr str-len )
 195     read
 196     repl-env swap eval
 197     print ;
 198
 199 create buff 128 allot
 200 77777777777 constant stack-leak-detect
 201
 202 : read-lines
 203     begin
 204       ." user> "
 205       stack-leak-detect
 206       buff 128 stdin read-line throw
 207     while ( num-bytes-read )
 208       buff swap ( str-addr str-len )
 209       ['] rep
 210       \ execute safe-type
 211       catch ?dup 0= if safe-type else ." Caught error " . endif
 212       cr
 213       stack-leak-detect <> if ." --stack leak--" cr endif
 214     repeat ;
 215
 216 read-lines
 217 cr
 218 bye