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