Commit | Line | Data |
---|---|---|
4d8cfe7e JB |
1 | readline = require './node_readline' |
2 | {id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls' | |
3 | {read_str} = require './reader' | |
4 | {pr_str} = require './printer' | |
5 | {Env} = require './env' | |
6 | {runtime-error, ns, unpack-tco} = require './core' | |
7 | {list-to-pairs} = require './utils' | |
8 | ||
9 | ||
10 | defer-tco = (env, ast) -> | |
11 | type: \tco | |
12 | env: env | |
13 | ast: ast | |
14 | eval: -> eval_ast env, ast | |
15 | ||
16 | ||
17 | is-thruthy = ({type, value}) -> | |
18 | type != \const or value not in [\nil \false] | |
19 | ||
20 | ||
21 | fmap-ast = (fn, {type, value}: ast) --> | |
22 | {type: type, value: fn value} | |
23 | ||
24 | ||
25 | make-symbol = (name) -> {type: \symbol, value: name} | |
26 | make-list = (value) -> {type: \list, value: value} | |
27 | make-call = (name, params) -> make-list [make-symbol name] ++ params | |
28 | is-symbol = (ast, name) -> ast.type == \symbol and ast.value == name | |
29 | ||
30 | ||
31 | eval_simple = (env, {type, value}: ast) -> | |
32 | switch type | |
33 | | \symbol => env.get value | |
34 | | \list, \vector => ast |> fmap-ast map eval_ast env | |
35 | | \map => ast |> fmap-ast Obj.map eval_ast env | |
36 | | otherwise => ast | |
37 | ||
38 | ||
39 | eval_ast = (env, ast) --> | |
40 | loop | |
41 | if ast.type != \list | |
42 | return eval_simple env, ast | |
43 | ||
44 | ast = macroexpand env, ast | |
45 | if ast.type != \list | |
46 | return eval_simple env, ast | |
47 | else if ast.value.length == 0 | |
48 | return ast | |
49 | ||
50 | result = if ast.value[0].type == \symbol | |
51 | params = ast.value[1 to] | |
52 | switch ast.value[0].value | |
53 | | 'def!' => eval_def env, params | |
54 | | 'let*' => eval_let env, params | |
55 | | 'do' => eval_do env, params | |
56 | | 'if' => eval_if env, params | |
57 | | 'fn*' => eval_fn env, params | |
58 | | 'quote' => eval_quote env, params | |
59 | | 'quasiquote' => eval_quasiquote env, params | |
60 | | 'defmacro!' => eval_defmacro env, params | |
61 | | 'macroexpand' => eval_macroexpand env, params | |
62 | | 'try*' => eval_try env, params | |
63 | | otherwise => eval_apply env, ast.value | |
64 | else | |
65 | eval_apply env, ast.value | |
66 | ||
67 | if result.type == \tco | |
68 | {env, ast} = result | |
69 | else | |
70 | return result | |
71 | ||
72 | ||
73 | check_params = (name, params, expected) -> | |
74 | if params.length != expected | |
75 | runtime-error "'#{name}' expected #{expected} parameters, | |
76 | got #{params.length}" | |
77 | ||
78 | ||
79 | eval_def = (env, params) -> | |
80 | check_params 'def!', params, 2 | |
81 | ||
82 | # Name is in the first parameter, and is not evaluated. | |
83 | name = params[0] | |
84 | if name.type != \symbol | |
85 | runtime-error "expected a symbol for the first parameter | |
86 | of def!, got a #{name.type}" | |
87 | ||
88 | # Evaluate the second parameter and store | |
89 | # it under name in the env. | |
90 | env.set name.value, (eval_ast env, params[1]) | |
91 | ||
92 | ||
93 | eval_let = (env, params) -> | |
94 | check_params 'let*', params, 2 | |
95 | ||
96 | binding_list = params[0] | |
97 | if binding_list.type not in [\list \vector] | |
98 | runtime-error "expected 1st parameter of 'let*' to | |
99 | be a binding list (or vector), | |
100 | got a #{binding_list.type}" | |
101 | else if binding_list.value.length % 2 != 0 | |
102 | runtime-error "binding list of 'let*' must have an even | |
103 | number of parameters" | |
104 | ||
105 | # Make a new environment with the | |
106 | # current environment as outer. | |
107 | let_env = new Env env | |
108 | ||
109 | # Evaluate all binding values in the | |
110 | # new environment. | |
111 | binding_list.value | |
112 | |> list-to-pairs | |
113 | |> each ([binding_name, binding_value]) -> | |
114 | if binding_name.type != \symbol | |
115 | runtime-error "expected a symbol as binding name, | |
116 | got a #{binding_name.type}" | |
117 | ||
118 | let_env.set binding_name.value, (eval_ast let_env, binding_value) | |
119 | ||
120 | # Defer evaluation of let* body with TCO. | |
121 | defer-tco let_env, params[1] | |
122 | ||
123 | ||
124 | eval_do = (env, params) -> | |
125 | if params.length == 0 | |
126 | runtime-error "'do' expected at least one parameter" | |
127 | ||
128 | [...rest, last-param] = params | |
129 | rest |> each eval_ast env | |
130 | defer-tco env, last-param | |
131 | ||
132 | ||
133 | eval_if = (env, params) -> | |
134 | if params.length < 2 | |
135 | runtime-error "'if' expected at least 2 parameters" | |
136 | else if params.length > 3 | |
137 | runtime-error "'if' expected at most 3 parameters" | |
138 | ||
139 | cond = eval_ast env, params[0] | |
140 | if is-thruthy cond | |
141 | defer-tco env, params[1] | |
142 | else if params.length > 2 | |
143 | defer-tco env, params[2] | |
144 | else | |
145 | {type: \const, value: \nil} | |
146 | ||
147 | ||
148 | eval_fn = (env, params) -> | |
149 | check_params 'fn*', params, 2 | |
150 | ||
151 | if params[0].type not in [\list \vector] | |
152 | runtime-error "'fn*' expected first parameter to be a list or vector." | |
153 | ||
154 | if not all (.type == \symbol), params[0].value | |
155 | runtime-error "'fn*' expected only symbols in the parameters list." | |
156 | ||
157 | binds = params[0].value |> map (.value) | |
158 | vargs = null | |
159 | ||
160 | # Parse variadic bind. | |
161 | if binds.length >= 2 | |
162 | [...rest, amper, name] = binds | |
163 | if amper == '&' and name != '&' | |
164 | binds = rest | |
165 | vargs = name | |
166 | ||
167 | if elem-index '&', binds | |
168 | runtime-error "'fn*' invalid usage of variadic parameters." | |
169 | ||
170 | if (unique binds).length != binds.length | |
171 | runtime-error "'fn*' duplicate symbols in parameters list." | |
172 | ||
173 | body = params[1] | |
174 | ||
175 | fn_instance = (...values) -> | |
176 | if not vargs and values.length != binds.length | |
177 | runtime-error "function expected #{binds.length} parameters, | |
178 | got #{values.length}" | |
179 | else if vargs and values.length < binds.length | |
180 | runtime-error "function expected at least | |
181 | #{binds.length} parameters, | |
182 | got #{values.length}" | |
183 | ||
184 | # Set binds to values in the new env. | |
185 | fn_env = new Env env | |
186 | ||
187 | for [name, value] in (zip binds, values) | |
188 | fn_env.set name, value | |
189 | ||
190 | if vargs | |
191 | fn_env.set vargs, | |
192 | make-list values.slice binds.length | |
193 | ||
194 | # Defer evaluation of the function body to TCO. | |
195 | defer-tco fn_env, body | |
196 | ||
197 | {type: \function, value: fn_instance, is_macro: false} | |
198 | ||
199 | ||
200 | eval_apply = (env, list) -> | |
201 | [fn, ...args] = list |> map eval_ast env | |
202 | if fn.type != \function | |
203 | runtime-error "#{fn.value} is not a function, got a #{fn.type}" | |
204 | ||
205 | fn.value.apply env, args | |
206 | ||
207 | ||
208 | eval_quote = (env, params) -> | |
209 | if params.length != 1 | |
210 | runtime-error "quote expected 1 parameter, got #{params.length}" | |
211 | ||
212 | params[0] | |
213 | ||
214 | ||
215 | is-pair = (ast) -> ast.type in [\list \vector] and ast.value.length != 0 | |
216 | ||
217 | ||
218 | eval_quasiquote = (env, params) -> | |
219 | if params.length != 1 | |
220 | runtime-error "quasiquote expected 1 parameter, got #{params.length}" | |
221 | ||
222 | ast = params[0] | |
223 | new-ast = if not is-pair ast | |
224 | make-call 'quote', [ast] | |
225 | else if is-symbol ast.value[0], 'unquote' | |
226 | ast.value[1] | |
227 | else if is-pair ast.value[0] and \ | |
228 | is-symbol ast.value[0].value[0], 'splice-unquote' | |
229 | make-call 'concat', [ | |
230 | ast.value[0].value[1] | |
231 | make-call 'quasiquote', [make-list ast.value[1 to]] | |
232 | ] | |
233 | else | |
234 | make-call 'cons', [ | |
235 | make-call 'quasiquote', [ast.value[0]] | |
236 | make-call 'quasiquote', [make-list ast.value[1 to]] | |
237 | ] | |
238 | ||
239 | defer-tco env, new-ast | |
240 | ||
241 | ||
242 | eval_defmacro = (env, params) -> | |
243 | check_params 'def!', params, 2 | |
244 | ||
245 | # Name is in the first parameter, and is not evaluated. | |
246 | name = params[0] | |
247 | if name.type != \symbol | |
248 | runtime-error "expected a symbol for the first parameter | |
249 | of defmacro!, got a #{name.type}" | |
250 | ||
251 | # Evaluate the second parameter. | |
252 | fn = eval_ast env, params[1] | |
253 | if fn.type != \function | |
254 | runtime-error "expected a function for the second parameter | |
255 | of defmacro!, got a #{fn.type}" | |
256 | ||
257 | # Copy fn and mark the function as a macro. | |
258 | macro_fn = fn with is_macro: true | |
259 | env.set name.value, macro_fn | |
260 | ||
261 | ||
262 | get-macro-fn = (env, ast) -> | |
263 | if ast.type == \list and | |
264 | ast.value.length != 0 and | |
265 | ast.value[0].type == \symbol | |
266 | fn = env.try-get ast.value[0].value | |
267 | if fn and fn.type == \function and fn.is_macro | |
268 | then fn | |
269 | ||
270 | ||
271 | macroexpand = (env, ast) -> | |
272 | loop # until ast is not a macro function call. | |
273 | macro_fn = get-macro-fn env, ast | |
274 | if not macro_fn then return ast | |
275 | ast = unpack-tco <| macro_fn.value.apply env, ast.value[1 to] | |
276 | ||
277 | ||
278 | eval_macroexpand = (env, params) -> | |
279 | if params.length != 1 | |
280 | runtime-error "'macroexpand' expected 1 parameter, | |
281 | got #{params.length}" | |
282 | ||
283 | macroexpand env, params[0] | |
284 | ||
285 | ||
286 | eval_try = (env, params) -> | |
dd7a4f55 JM |
287 | if params.length > 2 |
288 | runtime-error "'try*' expected 1 or 2 parameters, | |
4d8cfe7e | 289 | got #{params.length}" |
4d8cfe7e | 290 | try-form = params[0] |
dd7a4f55 JM |
291 | if params.length == 1 |
292 | return eval_ast env, try-form | |
293 | ||
4d8cfe7e JB |
294 | catch-clause = params[1] |
295 | if catch-clause.type != \list or | |
296 | catch-clause.value.length != 3 or | |
297 | not (is-symbol catch-clause.value[0], 'catch*') or | |
298 | catch-clause.value[1].type != \symbol | |
299 | runtime-error "'try*' expected the second parameter to be | |
300 | of the form (catch* A B)" | |
301 | ||
302 | try | |
303 | eval_ast env, try-form | |
304 | catch error | |
305 | error-symbol = catch-clause.value[1].value | |
306 | error-value = \ | |
307 | if error.message | |
308 | then {type: \string, value: error.message} | |
309 | else error | |
310 | ||
311 | catch-env = new Env env | |
312 | catch-env.set error-symbol, error-value | |
313 | eval_ast catch-env, catch-clause.value[2] | |
314 | ||
315 | ||
316 | repl_env = new Env | |
317 | for symbol, value of ns | |
318 | repl_env.set symbol, value | |
319 | ||
320 | # Evil eval. | |
321 | repl_env.set 'eval', do | |
322 | type: \function | |
323 | value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). | |
324 | ||
325 | # Read, Evaluate, Print | |
326 | rep = (line) -> | |
327 | line | |
328 | |> read_str | |
329 | |> eval_ast repl_env | |
330 | |> (ast) -> pr_str ast, print_readably=true | |
331 | ||
332 | ||
f4495e1e NB |
333 | # Define not. |
334 | rep '(def! not (fn* (x) (if x false true)))' | |
335 | ||
4d8cfe7e JB |
336 | # Define load-file. |
337 | rep ' | |
338 | (def! load-file | |
339 | (fn* (f) | |
340 | (eval | |
341 | (read-string | |
342 | (str "(do " (slurp f) ")")))))' | |
343 | ||
344 | # Define cond. | |
345 | rep ' | |
346 | (defmacro! cond | |
347 | (fn* (& xs) | |
348 | (if (> (count xs) 0) | |
349 | (list \'if (first xs) | |
350 | (if (> (count xs) 1) | |
351 | (nth xs 1) | |
352 | (throw "odd number of forms to cond")) | |
353 | (cons \'cond (rest (rest xs)))))))' | |
354 | ||
355 | rep '(def! *gensym-counter* (atom 0))' | |
356 | ||
357 | rep ' | |
358 | (def! gensym | |
359 | (fn* [] | |
360 | (symbol | |
361 | (str "G__" | |
362 | (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))' | |
363 | ||
364 | rep ' | |
365 | (defmacro! or | |
366 | (fn* (& xs) | |
367 | (if (empty? xs) | |
368 | nil | |
369 | (if (= 1 (count xs)) | |
370 | (first xs) | |
371 | (let* (condvar (gensym)) | |
372 | `(let* (~condvar ~(first xs)) | |
373 | (if ~condvar ~condvar (or ~@(rest xs)))))))))' | |
374 | ||
375 | # Parse program arguments. | |
376 | # The first two (exe and core-file) are, respectively, | |
377 | # the interpreter executable (nodejs or lsc) and the | |
378 | # source file being executed (stepX_*.(ls|js)). | |
379 | [exe, core-file, mal-file, ...argv] = process.argv | |
380 | ||
381 | repl_env.set '*ARGV*', do | |
382 | type: \list | |
383 | value: argv |> map (arg) -> | |
384 | type: \string | |
385 | value: arg | |
386 | ||
387 | repl_env.set '*host-language*', | |
388 | {type: \string, value: 'livescript'} | |
389 | ||
390 | ||
391 | if mal-file | |
392 | rep "(load-file \"#{mal-file}\")" | |
393 | else | |
394 | # REPL. | |
395 | rep '(println (str "Mal [" *host-language* "]"))' | |
396 | loop | |
397 | line = readline.readline 'user> ' | |
398 | break if not line? or line == '' | |
399 | try | |
400 | console.log rep line | |
dd7a4f55 JM |
401 | catch error |
402 | if error.message | |
403 | then console.error error.message | |
404 | else console.error "Error:", pr_str error, print_readably=true |