core MalEnv. constant repl-env
-\ Fully evalutate any Mal object:
-def-protocol-method mal-eval ( env ast -- val )
-
-\ Invoke an object, given whole env and unevaluated argument forms:
-def-protocol-method invoke ( argv argc mal-fn -- ... )
+: read read-str ;
+: eval ( env obj ) mal-eval ;
+: print
+ \ ." Type: " dup mal-type @ type-name safe-type cr
+ pr-str ;
-MalDefault extend mal-eval nip ;; drop
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
MalKeyword
- extend invoke { env list kw -- val }
- 0 kw env list MalList/start @ cell+ @ mal-eval get
+ extend eval-invoke { env list kw -- val }
+ 0 kw env list MalList/start @ cell+ @ eval get
?dup 0= if
\ compute not-found value
list MalList/count @ 1 > if
- env list MalList/start @ 2 cells + @ mal-eval
+ env list MalList/start @ 2 cells + @ eval
else
mal-nil
endif
endif ;;
drop
-\ eval all but the first item of list, storing in temporary memory
-\ that should be freed with free-eval-rest when done.
-: eval-rest { env list -- mem-token argv argc }
- \ Pass args on dictionary stack (!)
- \ TODO: consider allocate and free of a real MalList instead
- \ Normal list, evaluate and invoke
- here { val-start }
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
list MalList/start @ cell+ { expr-start }
- list MalList/count @ 1- dup { argc } 0 ?do
- env expr-start i cells + @ mal-eval ,
+ list MalList/count @ 1- { argc }
+ argc cells allocate throw { target }
+ argc 0 ?do
+ env expr-start i cells + @ eval
+ target i cells + !
loop
- val-start val-start argc ;
-
-: free-eval-rest ( mem-token/val-start -- )
- here - allot ;
+ target argc ;
MalNativeFn
- extend invoke ( env list this -- list )
+ extend eval-invoke ( env list this -- list )
MalNativeFn/xt @ { xt }
- eval-rest ( mem-token argv argc )
- xt execute ( mem-token return-val )
- swap free-eval-rest ;;
+ eval-rest ( argv argc )
+ xt execute ( return-val ) ;;
drop
SpecialOp
- extend invoke ( env list this -- list )
+ extend eval-invoke ( env list this -- list )
SpecialOp/xt @ execute ;;
drop
defspecial def! { env list -- val }
list MalList/start @ cell+ { arg0 }
arg0 @ ( key )
- env arg0 cell+ @ mal-eval dup { val } ( key val )
- env env/set
- val ;;
+ env arg0 cell+ @ eval dup { val } ( key val )
+ env env/set val ;;
defspecial let* { old-env list -- val }
old-env MalEnv. { env }
dup MalList/start @ { bindings-start } ( list )
MalList/count @ 0 +do
bindings-start i cells + dup @ swap cell+ @ ( sym expr )
- env swap mal-eval
+ env swap eval
env env/set
2 +loop
- env arg0 cell+ @ mal-eval
+ env arg0 cell+ @ eval
\ TODO: dec refcount of env
;;
0
list MalList/count @ 1 ?do
drop
- dup i cells + @ env swap mal-eval
+ dup i cells + @ env swap eval
loop
nip ;;
defspecial if { env list -- val }
list MalList/start @ cell+ { arg0 }
- env arg0 @ mal-eval ( test-val )
+ env arg0 @ eval ( test-val )
dup mal-false = if
drop -1
else
if
\ branch to false
list MalList/count @ 3 > if
- env arg0 cell+ cell+ @ mal-eval
+ env arg0 cell+ cell+ @ eval
else
mal-nil
endif
else
\ branch to true
- env arg0 cell+ @ mal-eval
+ env arg0 cell+ @ eval
endif ;;
-MalUserFn
- extend invoke { call-env list mal-fn -- list }
- call-env list eval-rest { mem-token argv argc }
+s" &" MalSymbol. constant &-sym
- mal-fn MalUserFn/formal-args @ dup { f-args-list }
- MalList/count @ argc 2dup = if
- 2drop
- else
- ." Argument mismatch on user fn. Got " . ." but expected " . cr
- 1 throw
- endif
+MalUserFn
+ extend eval-invoke { call-env list mal-fn -- list }
+ call-env list eval-rest { argv argc }
+ mal-fn MalUserFn/formal-args @ { f-args-list }
mal-fn MalUserFn/env @ MalEnv. { env }
f-args-list MalList/start @ { f-args }
+ f-args-list MalList/count @ ?dup 0= if else
+ \ pass nil for last arg, unless overridden below
+ 1- cells f-args + @ mal-nil env env/set
+ endif
argc 0 ?do
f-args i cells + @
+ dup &-sym m= if
+ drop
+ f-args i 1+ cells + @ ( more-args-symbol )
+ MalList new ( sym more-args )
+ argc i - dup { c } over MalList/count !
+ c cells allocate throw dup { start } over MalList/start !
+ argv i cells + start c cells cmove
+ env env/set
+ leave
+ endif
argv i cells + @
env env/set
loop
- env mal-fn MalUserFn/body @ mal-eval
-
- mem-token free-eval-rest ;;
+ env mal-fn MalUserFn/body @ eval ;;
+drop
defspecial fn* { env list -- val }
list MalList/start @ cell+ { arg0 }
MalSymbol
extend mal-eval { env sym -- val }
- 0 sym env get
+ sym env env/get-addr
dup 0= if
drop
- ." Symbol '"
- sym as-native safe-type
- ." ' not found." cr
+ ." Symbol '" sym pr-str safe-type ." ' not found." cr
1 throw
+ else
+ @
endif ;;
drop
-: mal-eval-ast { env list -- list }
+: eval-ast { env list -- list }
here
list MalList/start @ { expr-start }
list MalList/count @ 0 ?do
- env expr-start i cells + @ mal-eval ,
+ env expr-start i cells + @ eval ,
loop
here>MalList ;
MalList
extend mal-eval { env list -- val }
- env list MalList/start @ @ mal-eval
- env list rot invoke ;;
+ env list MalList/start @ @ eval
+ env list rot eval-invoke ;;
drop
MalVector
extend mal-eval ( env vector -- vector )
- MalVector/list @ mal-eval-ast
+ MalVector/list @ eval-ast
MalVector new swap over MalVector/list ! ;;
drop
MalMap
extend mal-eval ( env map -- map )
- MalMap/list @ mal-eval-ast
+ MalMap/list @ eval-ast
MalMap new swap over MalMap/list ! ;;
drop
-: read read-str ;
-: eval ( env obj ) mal-eval ;
-: print
- \ ." Type: " dup mal-type @ type-name safe-type cr
- pr-str ;
-
-: rep ( str -- val )
+: rep ( str-addr str-len -- str-addr str-len )
read
repl-env swap eval
print ;
create buff 128 allot
+77777777777 constant stack-leak-detect
: read-lines
begin
." user> "
- 77777777777
+ stack-leak-detect
buff 128 stdin read-line throw
- while
- buff swap
+ while ( num-bytes-read )
+ buff swap ( str-addr str-len )
['] rep
- execute safe-type
- \ catch 0= if safe-type else ." Caught error" endif
+ \ execute safe-type
+ catch ?dup 0= if safe-type else ." Caught error " . endif
cr
- 77777777777 <> if ." --stack leak--" cr endif
+ stack-leak-detect <> if ." --stack leak--" cr endif
repeat ;
read-lines
HCoop / jackhill / mal.git / blobdiff