Commit | Line | Data |
---|---|---|
a650ae5b 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} = 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, {type, value}: ast) --> | |
40 | loop | |
41 | if type != \list | |
42 | return eval_simple env, ast | |
43 | else if value.length == 0 | |
44 | return ast | |
45 | ||
46 | result = if value[0].type == \symbol | |
47 | params = value[1 to] | |
48 | switch value[0].value | |
49 | | 'def!' => eval_def env, params | |
50 | | 'let*' => eval_let env, params | |
51 | | 'do' => eval_do env, params | |
52 | | 'if' => eval_if env, params | |
53 | | 'fn*' => eval_fn env, params | |
54 | | 'quote' => eval_quote env, params | |
55 | | 'quasiquote' => eval_quasiquote env, params | |
56 | | otherwise => eval_apply env, value | |
57 | else | |
58 | eval_apply env, value | |
59 | ||
60 | if result.type == \tco | |
61 | env = result.env | |
62 | {type, value}: ast = result.ast | |
63 | else | |
64 | return result | |
65 | ||
66 | ||
67 | check_params = (name, params, expected) -> | |
68 | if params.length != expected | |
69 | runtime-error "'#{name}' expected #{expected} parameters, | |
70 | got #{params.length}" | |
71 | ||
72 | ||
73 | eval_def = (env, params) -> | |
74 | check_params 'def!', params, 2 | |
75 | ||
76 | # Name is in the first parameter, and is not evaluated. | |
77 | name = params[0] | |
78 | if name.type != \symbol | |
79 | runtime-error "expected a symbol for the first parameter | |
80 | of def!, got a #{name.type}" | |
81 | ||
82 | # Evaluate the second parameter and store | |
83 | # it under name in the env. | |
84 | env.set name.value, (eval_ast env, params[1]) | |
85 | ||
86 | ||
87 | eval_let = (env, params) -> | |
88 | check_params 'let*', params, 2 | |
89 | ||
90 | binding_list = params[0] | |
91 | if binding_list.type not in [\list \vector] | |
92 | runtime-error "expected 1st parameter of 'let*' to | |
93 | be a binding list (or vector), | |
94 | got a #{binding_list.type}" | |
95 | else if binding_list.value.length % 2 != 0 | |
96 | runtime-error "binding list of 'let*' must have an even | |
97 | number of parameters" | |
98 | ||
99 | # Make a new environment with the | |
100 | # current environment as outer. | |
101 | let_env = new Env env | |
102 | ||
103 | # Evaluate all binding values in the | |
104 | # new environment. | |
105 | binding_list.value | |
106 | |> list-to-pairs | |
107 | |> each ([binding_name, binding_value]) -> | |
108 | if binding_name.type != \symbol | |
109 | runtime-error "expected a symbol as binding name, | |
110 | got a #{binding_name.type}" | |
111 | ||
112 | let_env.set binding_name.value, (eval_ast let_env, binding_value) | |
113 | ||
114 | # Defer evaluation of let* body with TCO. | |
115 | defer-tco let_env, params[1] | |
116 | ||
117 | ||
118 | eval_do = (env, params) -> | |
119 | if params.length == 0 | |
120 | runtime-error "'do' expected at least one parameter" | |
121 | ||
122 | [...rest, last-param] = params | |
123 | rest |> each eval_ast env | |
124 | defer-tco env, last-param | |
125 | ||
126 | ||
127 | eval_if = (env, params) -> | |
128 | if params.length < 2 | |
129 | runtime-error "'if' expected at least 2 parameters" | |
130 | else if params.length > 3 | |
131 | runtime-error "'if' expected at most 3 parameters" | |
132 | ||
133 | cond = eval_ast env, params[0] | |
134 | if is-thruthy cond | |
135 | defer-tco env, params[1] | |
136 | else if params.length > 2 | |
137 | defer-tco env, params[2] | |
138 | else | |
139 | {type: \const, value: \nil} | |
140 | ||
141 | ||
142 | eval_fn = (env, params) -> | |
143 | check_params 'fn*', params, 2 | |
144 | ||
145 | if params[0].type not in [\list \vector] | |
146 | runtime-error "'fn*' expected first parameter to be a list or vector." | |
147 | ||
148 | if not all (.type == \symbol), params[0].value | |
149 | runtime-error "'fn*' expected only symbols in the parameters list." | |
150 | ||
151 | binds = params[0].value |> map (.value) | |
152 | vargs = null | |
153 | ||
154 | # Parse variadic bind. | |
155 | if binds.length >= 2 | |
156 | [...rest, amper, name] = binds | |
157 | if amper == '&' and name != '&' | |
158 | binds = rest | |
159 | vargs = name | |
160 | ||
161 | if elem-index '&', binds | |
162 | runtime-error "'fn*' invalid usage of variadic parameters." | |
163 | ||
164 | if (unique binds).length != binds.length | |
165 | runtime-error "'fn*' duplicate symbols in parameters list." | |
166 | ||
167 | body = params[1] | |
168 | ||
169 | fn_instance = (...values) -> | |
170 | if not vargs and values.length != binds.length | |
171 | runtime-error "function expected #{binds.length} parameters, | |
172 | got #{values.length}" | |
173 | else if vargs and values.length < binds.length | |
174 | runtime-error "function expected at least | |
175 | #{binds.length} parameters, | |
176 | got #{values.length}" | |
177 | ||
178 | # Set binds to values in the new env. | |
179 | fn_env = new Env env | |
180 | ||
181 | for [name, value] in (zip binds, values) | |
182 | fn_env.set name, value | |
183 | ||
184 | if vargs | |
185 | fn_env.set vargs, | |
186 | make-list values.slice binds.length | |
187 | ||
188 | # Defer evaluation of the function body to TCO. | |
189 | defer-tco fn_env, body | |
190 | ||
191 | {type: \function, value: fn_instance} | |
192 | ||
193 | ||
194 | eval_apply = (env, list) -> | |
195 | [fn, ...args] = list |> map eval_ast env | |
196 | if fn.type != \function | |
197 | runtime-error "#{fn.value} is not a function" | |
198 | ||
199 | fn.value.apply env, args | |
200 | ||
201 | ||
202 | eval_quote = (env, params) -> | |
203 | if params.length != 1 | |
204 | runtime-error "quote expected 1 parameter, got #{params.length}" | |
205 | ||
206 | params[0] | |
207 | ||
208 | ||
209 | is-pair = (ast) -> ast.type in [\list \vector] and ast.value.length != 0 | |
210 | ||
211 | ||
212 | eval_quasiquote = (env, params) -> | |
19677091 JB |
213 | if params.length != 1 |
214 | runtime-error "quasiquote expected 1 parameter, got #{params.length}" | |
a650ae5b JB |
215 | |
216 | ast = params[0] | |
217 | new-ast = if not is-pair ast | |
218 | make-call 'quote', [ast] | |
219 | else if is-symbol ast.value[0], 'unquote' | |
220 | ast.value[1] | |
221 | else if is-pair ast.value[0] and \ | |
222 | is-symbol ast.value[0].value[0], 'splice-unquote' | |
223 | make-call 'concat', [ | |
224 | ast.value[0].value[1] | |
225 | make-call 'quasiquote', [make-list ast.value[1 to]] | |
226 | ] | |
227 | else | |
228 | make-call 'cons', [ | |
229 | make-call 'quasiquote', [ast.value[0]] | |
230 | make-call 'quasiquote', [make-list ast.value[1 to]] | |
231 | ] | |
232 | ||
233 | defer-tco env, new-ast | |
234 | ||
235 | ||
236 | repl_env = new Env | |
237 | for symbol, value of ns | |
238 | repl_env.set symbol, value | |
239 | ||
240 | # Evil eval. | |
241 | repl_env.set 'eval', do | |
242 | type: \function | |
243 | value: (ast) -> eval_ast repl_env, ast # or use current env? (@ = this). | |
244 | ||
245 | ||
246 | rep = (line) -> | |
247 | line | |
248 | |> read_str | |
249 | |> eval_ast repl_env | |
250 | |> (ast) -> pr_str ast, print_readably=true | |
251 | ||
252 | # Define load-file. | |
253 | rep ' | |
254 | (def! load-file | |
255 | (fn* (f) | |
256 | (eval | |
257 | (read-string | |
258 | (str "(do " (slurp f) ")")))))' | |
259 | ||
260 | # Parse program arguments. | |
261 | # The first two (exe and core-file) are, respectively, | |
262 | # the interpreter executable (nodejs or lsc) and the | |
263 | # source file being executed (stepX_*.(ls|js)). | |
264 | [exe, core-file, mal-file, ...argv] = process.argv | |
265 | ||
266 | repl_env.set '*ARGV*', do | |
267 | type: \list | |
268 | value: argv |> map (arg) -> | |
269 | type: \string | |
270 | value: arg | |
271 | ||
272 | if mal-file | |
273 | rep "(load-file \"#{mal-file}\")" | |
274 | else | |
275 | # REPL. | |
276 | loop | |
277 | line = readline.readline 'user> ' | |
278 | break if not line? or line == '' | |
279 | try | |
280 | console.log rep line | |
281 | catch {message} | |
282 | console.error message |