Commit | Line | Data |
---|---|---|
794bfca1 C |
1 | require reader.fs |
2 | require printer.fs | |
3 | require core.fs | |
4 | ||
5 | core MalEnv. constant repl-env | |
6 | ||
794bfca1 C |
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 | ||
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 | |
45c1894b | 25 | extend eval-invoke { env list kw -- val } |
794bfca1 C |
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 | |
45c1894b | 49 | extend eval-invoke ( env list this -- list ) |
794bfca1 C |
50 | MalNativeFn/xt @ { xt } |
51 | eval-rest ( argv argc ) | |
52 | xt execute ( return-val ) ;; | |
53 | drop | |
54 | ||
55 | SpecialOp | |
45c1894b | 56 | extend eval-invoke ( env list this -- list ) |
794bfca1 C |
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 ) | |
45c1894b | 118 | env env/set val ;; |
794bfca1 C |
119 | |
120 | defspecial let* { old-env list -- val } | |
121 | old-env MalEnv. { env } | |
122 | list MalList/start @ cell+ dup { arg0 } | |
123 | @ to-list | |
124 | dup MalList/start @ { bindings-start } ( list ) | |
125 | MalList/count @ 0 +do | |
126 | bindings-start i cells + dup @ swap cell+ @ ( sym expr ) | |
127 | env swap eval | |
128 | env env/set | |
129 | 2 +loop | |
130 | env arg0 cell+ @ TCO-eval | |
131 | \ TODO: dec refcount of env | |
132 | ;; | |
133 | ||
134 | defspecial do { env list -- val } | |
135 | list MalList/start @ { start } | |
136 | list MalList/count @ dup 1- { last } 1 ?do | |
137 | env start i cells + @ | |
138 | i last = if | |
139 | TCO-eval | |
140 | else | |
141 | eval drop | |
142 | endif | |
143 | loop ;; | |
144 | ||
145 | defspecial if { env list -- val } | |
146 | list MalList/start @ cell+ { arg0 } | |
147 | env arg0 @ eval ( test-val ) | |
148 | dup mal-false = if | |
149 | drop -1 | |
150 | else | |
151 | mal-nil = | |
152 | endif | |
153 | if | |
154 | \ branch to false | |
155 | list MalList/count @ 3 > if | |
156 | env arg0 cell+ cell+ @ TCO-eval | |
157 | else | |
158 | mal-nil | |
159 | endif | |
160 | else | |
161 | \ branch to true | |
162 | env arg0 cell+ @ TCO-eval | |
163 | endif ;; | |
164 | ||
165 | s" &" MalSymbol. constant &-sym | |
166 | ||
167 | MalUserFn | |
45c1894b | 168 | extend eval-invoke { call-env list mal-fn -- list } |
794bfca1 C |
169 | call-env list eval-rest { argv argc } |
170 | ||
171 | mal-fn MalUserFn/formal-args @ { f-args-list } | |
172 | mal-fn MalUserFn/env @ MalEnv. { env } | |
173 | ||
174 | f-args-list MalList/start @ { f-args } | |
175 | f-args-list MalList/count @ ?dup 0= if else | |
176 | \ pass nil for last arg, unless overridden below | |
177 | 1- cells f-args + @ mal-nil env env/set | |
178 | endif | |
179 | argc 0 ?do | |
180 | f-args i cells + @ | |
181 | dup &-sym m= if | |
182 | drop | |
183 | f-args i 1+ cells + @ ( more-args-symbol ) | |
184 | MalList new ( sym more-args ) | |
185 | argc i - dup { c } over MalList/count ! | |
186 | c cells allocate throw dup { start } over MalList/start ! | |
187 | argv i cells + start c cells cmove | |
188 | env env/set | |
189 | leave | |
190 | endif | |
191 | argv i cells + @ | |
192 | env env/set | |
193 | loop | |
194 | ||
195 | env mal-fn MalUserFn/body @ TCO-eval ;; | |
196 | drop | |
197 | ||
198 | defspecial fn* { env list -- val } | |
199 | list MalList/start @ cell+ { arg0 } | |
200 | MalUserFn new | |
201 | env over MalUserFn/env ! | |
202 | arg0 @ to-list over MalUserFn/formal-args ! | |
203 | arg0 cell+ @ over MalUserFn/body ! ;; | |
204 | ||
205 | MalSymbol | |
206 | extend mal-eval { env sym -- val } | |
a631063f | 207 | sym env env/get-addr |
794bfca1 C |
208 | dup 0= if |
209 | drop | |
a631063f | 210 | ." Symbol '" sym pr-str safe-type ." ' not found." cr |
794bfca1 | 211 | 1 throw |
a631063f C |
212 | else |
213 | @ | |
794bfca1 C |
214 | endif ;; |
215 | drop | |
216 | ||
217 | : eval-ast { env list -- list } | |
218 | here | |
219 | list MalList/start @ { expr-start } | |
220 | list MalList/count @ 0 ?do | |
221 | env expr-start i cells + @ eval , | |
222 | loop | |
223 | here>MalList ; | |
224 | ||
225 | MalList | |
226 | extend mal-eval { env list -- val } | |
227 | env list MalList/start @ @ eval | |
45c1894b | 228 | env list rot eval-invoke ;; |
794bfca1 C |
229 | drop |
230 | ||
231 | MalVector | |
232 | extend mal-eval ( env vector -- vector ) | |
233 | MalVector/list @ eval-ast | |
234 | MalVector new swap over MalVector/list ! ;; | |
235 | drop | |
236 | ||
237 | MalMap | |
238 | extend mal-eval ( env map -- map ) | |
239 | MalMap/list @ eval-ast | |
240 | MalMap new swap over MalMap/list ! ;; | |
241 | drop | |
242 | ||
243 | defcore eval ( argv argc ) | |
244 | drop @ repl-env swap eval ;; | |
245 | ||
45c1894b | 246 | : rep ( str-addr str-len -- str-addr str-len ) |
794bfca1 C |
247 | read |
248 | repl-env swap eval | |
249 | print ; | |
250 | ||
251 | : mk-args-list ( -- ) | |
252 | here | |
253 | begin | |
254 | next-arg 2dup 0 0 d<> while | |
255 | MalString. , | |
256 | repeat | |
257 | 2drop here>MalList ; | |
258 | ||
794bfca1 C |
259 | create buff 128 allot |
260 | 77777777777 constant stack-leak-detect | |
261 | ||
45c1894b C |
262 | s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop |
263 | ||
794bfca1 C |
264 | : repl ( -- ) |
265 | begin | |
266 | ." user> " | |
267 | stack-leak-detect | |
268 | buff 128 stdin read-line throw | |
45c1894b C |
269 | while ( num-bytes-read ) |
270 | buff swap ( str-addr str-len ) | |
794bfca1 | 271 | ['] rep |
45c1894b C |
272 | \ execute type |
273 | catch ?dup 0= if safe-type else ." Caught error " . endif | |
794bfca1 C |
274 | cr |
275 | stack-leak-detect <> if ." --stack leak--" cr endif | |
276 | repeat ; | |
277 | ||
278 | : main ( -- ) | |
279 | mk-args-list { args-list } | |
280 | args-list MalList/count @ 0= if | |
281 | s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set | |
282 | repl | |
283 | else | |
284 | args-list MalList/start @ @ { filename } | |
285 | s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set | |
286 | ||
287 | repl-env | |
288 | here s" load-file" MalSymbol. , filename , here>MalList | |
289 | eval print | |
290 | endif ; | |
291 | ||
292 | main | |
293 | cr | |
294 | bye |