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         0 0 s" ' not found" sym pr-str s" '" ...throw-str
 158     else
 159         @
 160     endif ;;
 161 drop
 162
 163 : eval-ast { env list -- list }
 164     here
 165     list MalList/start @ { expr-start }
 166     list MalList/count @ 0 ?do
 167         env expr-start i cells + @ eval ,
 168     loop
 169     here>MalList ;
 170
 171 MalList
 172   extend mal-eval { env list -- val }
 173     list MalList/count @ 0= if
 174         list
 175     else
 176         env list MalList/start @ @ eval
 177         env list rot eval-invoke
 178     endif ;;
 179 drop
 180
 181 MalVector
 182   extend mal-eval ( env vector -- vector )
 183     MalVector/list @ eval-ast
 184     MalVector new swap over MalVector/list ! ;;
 185 drop
 186
 187 MalMap
 188   extend mal-eval ( env map -- map )
 189     MalMap/list @ eval-ast
 190     MalMap new swap over MalMap/list ! ;;
 191 drop
 192
 193 : rep ( str-addr str-len -- str-addr str-len )
 194     read
 195     repl-env swap eval
 196     print ;
 197
 198 create buff 128 allot
 199 77777777777 constant stack-leak-detect
 200
 201 s\" (def! not (fn* (x) (if x false true)))" rep 2drop
 202
 203 : read-lines
 204     begin
 205       ." user> "
 206       stack-leak-detect
 207       buff 128 stdin read-line throw
 208     while ( num-bytes-read )
 209       dup 0 <> if
 210         buff swap ( str-addr str-len )
 211         ['] rep
 212         \ execute ['] nop \ uncomment to see stack traces
 213         catch ?dup 0= if
 214             safe-type cr
 215             stack-leak-detect <> if ." --stack leak--" cr endif
 216         else { errno }
 217             begin stack-leak-detect = until
 218             errno 1 <> if
 219                 s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
 220                 to exception-object
 221             endif
 222             ." Uncaught exception: "
 223             exception-object pr-str safe-type cr
 224         endif
 225       endif
 226     repeat ;
 227
 228 read-lines
 229 cr
 230 bye