Commit | Line | Data |
---|---|---|
cbbb51b4 | 1 | with Ada.Command_Line; |
5a07bb53 | 2 | with Ada.Containers.Vectors; |
00c3a3c3 | 3 | with Ada.Environment_Variables; |
cbbb51b4 | 4 | with Ada.Text_IO.Unbounded_IO; |
daffc668 | 5 | |
cbbb51b4 | 6 | with Core; |
11932a6c | 7 | with Envs; |
00c3a3c3 | 8 | with Err; |
5a07bb53 | 9 | with Garbage_Collected; |
cbbb51b4 NB |
10 | with Printer; |
11 | with Reader; | |
11932a6c | 12 | with Readline; |
00c3a3c3 NB |
13 | with Types.Builtins; |
14 | with Types.Fns; | |
8185fe14 | 15 | with Types.Macros; |
daffc668 | 16 | with Types.Maps; |
00c3a3c3 | 17 | with Types.Sequences; |
8185fe14 | 18 | with Types.Strings; |
cbbb51b4 NB |
19 | |
20 | procedure StepA_Mal is | |
21 | ||
5a07bb53 | 22 | Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval"); |
00c3a3c3 | 23 | |
8185fe14 NB |
24 | use type Types.T; |
25 | use all type Types.Kind_Type; | |
26 | use type Types.Strings.Instance; | |
5a07bb53 | 27 | package ACL renames Ada.Command_Line; |
8185fe14 | 28 | package Vectors is new Ada.Containers.Vectors (Positive, Types.T); |
daffc668 | 29 | |
8185fe14 | 30 | function Read return Types.T_Array with Inline; |
cbbb51b4 | 31 | |
8185fe14 NB |
32 | function Eval (Ast0 : in Types.T; |
33 | Env0 : in Envs.Ptr) return Types.T; | |
34 | function Eval_Builtin (Args : in Types.T_Array) return Types.T; | |
5a07bb53 | 35 | -- The built-in variant needs to see the Repl variable. |
cbbb51b4 | 36 | |
8185fe14 NB |
37 | function Quasiquote (Ast : in Types.T; |
38 | Env : in Envs.Ptr) return Types.T; | |
daffc668 NB |
39 | -- Mergeing quote and quasiquote into eval with a flag triggering |
40 | -- a different behaviour as done for macros in step8 would improve | |
41 | -- the performances significantly, but Kanaka finds that it breaks | |
42 | -- too much the step structure shared by all implementations. | |
cbbb51b4 | 43 | |
8185fe14 | 44 | procedure Print (Ast : in Types.T) with Inline; |
cbbb51b4 | 45 | |
11932a6c | 46 | procedure Rep (Env : in Envs.Ptr) with Inline; |
cbbb51b4 | 47 | |
8185fe14 NB |
48 | function Eval_Map (Source : in Types.Maps.Instance; |
49 | Env : in Envs.Ptr) return Types.T; | |
50 | function Eval_Vector (Source : in Types.Sequences.Instance; | |
51 | Env : in Envs.Ptr) return Types.T; | |
52 | -- Helpers for the Eval function. | |
cbbb51b4 | 53 | |
00c3a3c3 NB |
54 | procedure Exec (Script : in String; |
55 | Env : in Envs.Ptr) with Inline; | |
56 | -- Read the script, eval its elements, but ignore the result. | |
cbbb51b4 NB |
57 | |
58 | ---------------------------------------------------------------------- | |
59 | ||
8185fe14 NB |
60 | function Eval (Ast0 : in Types.T; |
61 | Env0 : in Envs.Ptr) return Types.T | |
6e2b7ddf | 62 | is |
daffc668 NB |
63 | -- Use local variables, that can be rewritten when tail call |
64 | -- optimization goes to <<Restart>>. | |
8185fe14 | 65 | Ast : Types.T := Ast0; |
5a07bb53 | 66 | Env : Envs.Ptr := Env0; |
8185fe14 NB |
67 | Env_Reusable : Boolean := False; |
68 | -- True when the environment has been created in this recursion | |
69 | -- level, and has not yet been referenced by a closure. If so, | |
70 | -- we can reuse it instead of creating a subenvironment. | |
11932a6c | 71 | Macroexpanding : Boolean := False; |
8185fe14 | 72 | First : Types.T; |
cbbb51b4 | 73 | begin |
daffc668 | 74 | <<Restart>> |
00c3a3c3 NB |
75 | if Dbgeval then |
76 | Ada.Text_IO.New_Line; | |
77 | Ada.Text_IO.Put ("EVAL: "); | |
78 | Print (Ast); | |
5a07bb53 | 79 | Envs.Dump_Stack (Env.all); |
00c3a3c3 | 80 | end if; |
5a07bb53 | 81 | |
cbbb51b4 | 82 | case Ast.Kind is |
8185fe14 NB |
83 | when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key |
84 | | Kind_Macro | Types.Kind_Function => | |
6e2b7ddf | 85 | return Ast; |
cbbb51b4 | 86 | when Kind_Symbol => |
8185fe14 | 87 | return Env.all.Get (Ast.Str); |
cbbb51b4 | 88 | when Kind_Map => |
8185fe14 | 89 | return Eval_Map (Ast.Map.all, Env); |
cbbb51b4 | 90 | when Kind_Vector => |
8185fe14 | 91 | return Eval_Vector (Ast.Sequence.all, Env); |
cbbb51b4 | 92 | when Kind_List => |
a5d17b88 NB |
93 | null; |
94 | end case; | |
95 | ||
96 | -- Ast is a list. | |
5a07bb53 | 97 | if Ast.Sequence.all.Length = 0 then |
a5d17b88 NB |
98 | return Ast; |
99 | end if; | |
8185fe14 | 100 | First := Ast.Sequence.all.Data (1); |
a5d17b88 NB |
101 | |
102 | -- Special forms | |
103 | -- Ast is a non-empty list, First is its first element. | |
104 | case First.Kind is | |
105 | when Kind_Symbol => | |
8185fe14 | 106 | if First.Str.all = "if" then |
5a07bb53 | 107 | Err.Check (Ast.Sequence.all.Length in 3 .. 4, |
00c3a3c3 | 108 | "expected 2 or 3 parameters"); |
daffc668 | 109 | declare |
8185fe14 | 110 | Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env); |
daffc668 | 111 | begin |
8185fe14 NB |
112 | if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then |
113 | Ast := Ast.Sequence.all.Data (3); | |
cbbb51b4 | 114 | goto Restart; |
5a07bb53 | 115 | elsif Ast.Sequence.all.Length = 3 then |
8185fe14 | 116 | return Types.Nil; |
daffc668 | 117 | else |
8185fe14 | 118 | Ast := Ast.Sequence.all.Data (4); |
daffc668 NB |
119 | goto Restart; |
120 | end if; | |
121 | end; | |
8185fe14 NB |
122 | elsif First.Str.all = "let*" then |
123 | Err.Check (Ast.Sequence.all.Length = 3 | |
124 | and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence, | |
125 | "expected a sequence then a value"); | |
daffc668 | 126 | declare |
8185fe14 NB |
127 | Bindings : Types.T_Array |
128 | renames Ast.Sequence.all.Data (2).Sequence.all.Data; | |
daffc668 | 129 | begin |
8185fe14 NB |
130 | Err.Check (Bindings'Length mod 2 = 0, "expected even binds"); |
131 | if not Env_Reusable then | |
132 | Env := Envs.New_Env (Outer => Env); | |
133 | Env_Reusable := True; | |
134 | end if; | |
135 | for I in 0 .. Bindings'Length / 2 - 1 loop | |
136 | Env.all.Set (Bindings (Bindings'First + 2 * I), | |
137 | Eval (Bindings (Bindings'First + 2 * I + 1), Env)); | |
138 | -- This call checks key kind. | |
daffc668 | 139 | end loop; |
8185fe14 | 140 | Ast := Ast.Sequence.all.Data (3); |
daffc668 NB |
141 | goto Restart; |
142 | end; | |
8185fe14 NB |
143 | elsif First.Str.all = "quote" then |
144 | Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); | |
145 | return Ast.Sequence.all.Data (2); | |
146 | elsif First.Str.all = "def!" then | |
147 | Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); | |
148 | declare | |
149 | Key : Types.T renames Ast.Sequence.all.Data (2); | |
150 | Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); | |
151 | begin | |
152 | Env.all.Set (Key, Val); -- Check key kind. | |
153 | return Val; | |
154 | end; | |
155 | elsif First.Str.all = "defmacro!" then | |
156 | Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); | |
157 | declare | |
158 | Key : Types.T renames Ast.Sequence.all.Data (2); | |
159 | Fun : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env); | |
160 | Val : Types.T; | |
161 | begin | |
162 | Err.Check (Fun.Kind = Kind_Fn, "expected a function"); | |
163 | Val := Types.Macros.New_Macro (Fun.Fn.all); | |
164 | Env.all.Set (Key, Val); -- Check key kind. | |
165 | return Val; | |
166 | end; | |
c58f50e6 NB |
167 | elsif First.Str.all = "do" then |
168 | Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments"); | |
169 | declare | |
170 | Result : Types.T; | |
171 | begin | |
203f0903 | 172 | for I in 2 .. Ast.Sequence.all.Length - 1 loop |
c58f50e6 NB |
173 | Result := Eval (Ast.Sequence.all.Data (I), Env); |
174 | end loop; | |
c58f50e6 | 175 | end; |
203f0903 NB |
176 | Ast := Ast.Sequence.all.Data (Ast.Sequence.all.Length); |
177 | goto Restart; | |
8185fe14 NB |
178 | elsif First.Str.all = "fn*" then |
179 | Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); | |
180 | declare | |
181 | Params : Types.T renames Ast.Sequence.all.Data (2); | |
182 | begin | |
183 | Err.Check (Params.Kind in Types.Kind_Sequence, | |
184 | "first argument of fn* must be a sequence"); | |
185 | Env_Reusable := False; | |
186 | return Types.Fns.New_Function | |
187 | (Params => Params.Sequence, | |
188 | Ast => Ast.Sequence.all.Data (3), | |
189 | Env => Env); | |
190 | end; | |
191 | elsif First.Str.all = "macroexpand" then | |
5a07bb53 | 192 | Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); |
daffc668 | 193 | Macroexpanding := True; |
8185fe14 | 194 | Ast := Ast.Sequence.all.Data (2); |
daffc668 | 195 | goto Restart; |
8185fe14 | 196 | elsif First.Str.all = "quasiquote" then |
5a07bb53 | 197 | Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); |
8185fe14 NB |
198 | return Quasiquote (Ast.Sequence.all.Data (2), Env); |
199 | elsif First.Str.all = "try*" then | |
5a07bb53 | 200 | if Ast.Sequence.all.Length = 2 then |
8185fe14 | 201 | Ast := Ast.Sequence.all.Data (2); |
cbbb51b4 | 202 | goto Restart; |
daffc668 | 203 | end if; |
8185fe14 NB |
204 | Err.Check (Ast.Sequence.all.Length = 3 |
205 | and then Ast.Sequence.all.Data (3).Kind = Kind_List, | |
206 | "expected 1 parameter, maybe followed by a list"); | |
daffc668 | 207 | declare |
8185fe14 NB |
208 | A3 : Types.T_Array |
209 | renames Ast.Sequence.all.Data (3).Sequence.all.Data; | |
daffc668 | 210 | begin |
8185fe14 NB |
211 | Err.Check (A3'Length = 3 |
212 | and then A3 (A3'First).Kind = Kind_Symbol | |
213 | and then A3 (A3'First).Str.all = "catch*", | |
214 | "3rd parameter if present must be a catch* list"); | |
cbbb51b4 | 215 | begin |
8185fe14 | 216 | return Eval (Ast.Sequence.all.Data (2), Env); |
cbbb51b4 | 217 | exception |
5a07bb53 NB |
218 | when Err.Error => |
219 | null; | |
cbbb51b4 | 220 | end; |
8185fe14 NB |
221 | if not Env_Reusable then |
222 | Env := Envs.New_Env (Outer => Env); | |
223 | Env_Reusable := True; | |
224 | end if; | |
225 | Env.all.Set (A3 (A3'First + 1), Err.Data); -- check key kind | |
226 | Ast := A3 (A3'Last); | |
5a07bb53 | 227 | goto Restart; |
daffc668 NB |
228 | end; |
229 | else | |
a5d17b88 NB |
230 | -- Equivalent to First := Eval (First, Env) |
231 | -- except that we already know enough to spare a recursive call. | |
8185fe14 | 232 | First := Env.all.Get (First.Str); |
cbbb51b4 | 233 | end if; |
8185fe14 NB |
234 | when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key |
235 | | Kind_Macro | Types.Kind_Function => | |
a5d17b88 NB |
236 | -- Equivalent to First := Eval (First, Env) |
237 | -- except that we already know enough to spare a recursive call. | |
238 | null; | |
8185fe14 | 239 | when Types.Kind_Sequence | Kind_Map => |
a5d17b88 NB |
240 | -- Lists are definitely worth a recursion, and the two other |
241 | -- cases should be rare (they will report an error later). | |
242 | First := Eval (First, Env); | |
243 | end case; | |
244 | ||
245 | -- Apply phase. | |
246 | -- Ast is a non-empty list, | |
247 | -- First is its non-special evaluated first element. | |
248 | case First.Kind is | |
8185fe14 NB |
249 | when Kind_Macro => |
250 | -- Use the unevaluated arguments. | |
251 | if Macroexpanding then | |
252 | -- Evaluate the macro with tail call optimization. | |
253 | if not Env_Reusable then | |
254 | Env := Envs.New_Env (Outer => Env); | |
255 | Env_Reusable := True; | |
256 | end if; | |
257 | Env.all.Set_Binds | |
258 | (Binds => First.Macro.all.Params.all.Data, | |
259 | Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); | |
260 | Ast := First.Macro.all.Ast; | |
261 | goto Restart; | |
262 | else | |
263 | -- Evaluate the macro normally. | |
daffc668 | 264 | declare |
8185fe14 | 265 | New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env); |
daffc668 | 266 | begin |
8185fe14 NB |
267 | New_Env.all.Set_Binds |
268 | (Binds => First.Macro.all.Params.all.Data, | |
269 | Exprs => Ast.Sequence.all.Data | |
270 | (2 .. Ast.Sequence.all.Length)); | |
271 | Ast := Eval (First.Macro.all.Ast, New_Env); | |
272 | -- Then evaluate the result with TCO. | |
cbbb51b4 | 273 | goto Restart; |
daffc668 | 274 | end; |
8185fe14 NB |
275 | end if; |
276 | when Types.Kind_Function => | |
277 | null; | |
278 | when others => | |
279 | Err.Raise_With ("first element must be a function or macro"); | |
cbbb51b4 | 280 | end case; |
8185fe14 NB |
281 | -- We are applying a function. Evaluate its arguments. |
282 | declare | |
283 | Args : Types.T_Array (2 .. Ast.Sequence.all.Length); | |
284 | begin | |
285 | for I in Args'Range loop | |
286 | Args (I) := Eval (Ast.Sequence.all.Data (I), Env); | |
287 | end loop; | |
288 | case First.Kind is | |
289 | when Kind_Builtin => | |
290 | return First.Builtin.all (Args); | |
291 | when Kind_Builtin_With_Meta => | |
292 | return First.Builtin_With_Meta.all.Builtin.all (Args); | |
293 | when others => | |
294 | null; | |
295 | end case; | |
296 | -- Like Types.Fns.Apply, except that we use TCO. | |
297 | Env := Envs.New_Env (Outer => First.Fn.all.Env); | |
298 | Env_Reusable := True; | |
299 | Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data, | |
300 | Exprs => Args); | |
301 | Ast := First.Fn.all.Ast; | |
302 | goto Restart; | |
303 | end; | |
00c3a3c3 NB |
304 | exception |
305 | when Err.Error => | |
306 | if Macroexpanding then | |
307 | Err.Add_Trace_Line ("macroexpand", Ast); | |
308 | else | |
309 | Err.Add_Trace_Line ("eval", Ast); | |
310 | end if; | |
311 | raise; | |
cbbb51b4 NB |
312 | end Eval; |
313 | ||
8185fe14 NB |
314 | function Eval_Map (Source : in Types.Maps.Instance; |
315 | Env : in Envs.Ptr) return Types.T | |
316 | is | |
317 | use all type Types.Maps.Cursor; | |
318 | -- Copy the whole map so that keys are not hashed again. | |
319 | Result : constant Types.T := Types.Maps.New_Map (Source); | |
320 | Position : Types.Maps.Cursor := Result.Map.all.First; | |
321 | begin | |
322 | while Has_Element (Position) loop | |
323 | Result.Map.all.Replace_Element (Position, | |
324 | Eval (Element (Position), Env)); | |
325 | Next (Position); | |
326 | end loop; | |
327 | return Result; | |
328 | end Eval_Map; | |
329 | ||
330 | function Eval_Vector (Source : in Types.Sequences.Instance; | |
331 | Env : in Envs.Ptr) return Types.T | |
332 | is | |
333 | Ref : constant Types.Sequence_Ptr | |
334 | := Types.Sequences.Constructor (Source.Length); | |
335 | begin | |
336 | for I in Source.Data'Range loop | |
337 | Ref.all.Data (I) := Eval (Source.Data (I), Env); | |
338 | end loop; | |
339 | return (Kind_Vector, Ref); | |
340 | end Eval_Vector; | |
341 | ||
00c3a3c3 NB |
342 | procedure Exec (Script : in String; |
343 | Env : in Envs.Ptr) | |
11932a6c | 344 | is |
8185fe14 | 345 | Result : Types.T; |
cbbb51b4 | 346 | begin |
00c3a3c3 NB |
347 | for Expression of Reader.Read_Str (Script) loop |
348 | Result := Eval (Expression, Env); | |
349 | end loop; | |
11932a6c | 350 | pragma Unreferenced (Result); |
00c3a3c3 | 351 | end Exec; |
11932a6c | 352 | |
8185fe14 | 353 | procedure Print (Ast : in Types.T) is |
11932a6c NB |
354 | begin |
355 | Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); | |
356 | end Print; | |
cbbb51b4 | 357 | |
8185fe14 NB |
358 | function Quasiquote (Ast : in Types.T; |
359 | Env : in Envs.Ptr) return Types.T | |
6e2b7ddf | 360 | is |
cbbb51b4 | 361 | |
8185fe14 | 362 | function Quasiquote_List (List : in Types.T_Array) return Types.T; |
6e2b7ddf NB |
363 | -- Handle vectors and lists not starting with unquote. |
364 | ||
8185fe14 NB |
365 | function Quasiquote_List (List : in Types.T_Array) return Types.T is |
366 | Vector : Vectors.Vector; -- buffer for concatenation | |
367 | Tmp : Types.T; | |
6e2b7ddf | 368 | begin |
8185fe14 NB |
369 | for Elt of List loop |
370 | if Elt.Kind in Kind_List | |
371 | and then 0 < Elt.Sequence.all.Length | |
372 | and then Elt.Sequence.all.Data (1).Kind = Kind_Symbol | |
373 | and then Elt.Sequence.all.Data (1).Str.all = "splice-unquote" | |
6e2b7ddf | 374 | then |
8185fe14 | 375 | Err.Check (Elt.Sequence.all.Length = 2, |
00c3a3c3 | 376 | "splice-unquote expects 1 parameter"); |
8185fe14 | 377 | Tmp := Eval (Elt.Sequence.all.Data (2), Env); |
5a07bb53 | 378 | Err.Check (Tmp.Kind = Kind_List, |
00c3a3c3 | 379 | "splice_unquote expects a list"); |
8185fe14 NB |
380 | for Sub_Elt of Tmp.Sequence.all.Data loop |
381 | Vector.Append (Sub_Elt); | |
5a07bb53 | 382 | end loop; |
6e2b7ddf | 383 | else |
8185fe14 | 384 | Vector.Append (Quasiquote (Elt, Env)); |
daffc668 | 385 | end if; |
6e2b7ddf | 386 | end loop; |
5a07bb53 | 387 | -- Now that we know the number of elements, convert to a list. |
8185fe14 NB |
388 | declare |
389 | Sequence : constant Types.Sequence_Ptr | |
390 | := Types.Sequences.Constructor (Natural (Vector.Length)); | |
391 | begin | |
392 | for I in 1 .. Natural (Vector.Length) loop | |
393 | Sequence.all.Data (I) := Vector (I); | |
394 | end loop; | |
395 | return (Kind_List, Sequence); | |
396 | end; | |
6e2b7ddf NB |
397 | end Quasiquote_List; |
398 | ||
399 | begin -- Quasiquote | |
400 | case Ast.Kind is | |
401 | when Kind_Vector => | |
402 | -- When the test is updated, replace Kind_List with Kind_Vector. | |
8185fe14 | 403 | return Quasiquote_List (Ast.Sequence.all.Data); |
6e2b7ddf | 404 | when Kind_List => |
5a07bb53 | 405 | if 0 < Ast.Sequence.all.Length |
8185fe14 NB |
406 | and then Ast.Sequence.all.Data (1).Kind = Kind_Symbol |
407 | and then Ast.Sequence.all.Data (1).Str.all = "unquote" | |
6e2b7ddf | 408 | then |
5a07bb53 | 409 | Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); |
8185fe14 | 410 | return Eval (Ast.Sequence.all.Data (2), Env); |
6e2b7ddf | 411 | else |
8185fe14 | 412 | return Quasiquote_List (Ast.Sequence.all.Data); |
daffc668 | 413 | end if; |
6e2b7ddf NB |
414 | when others => |
415 | return Ast; | |
416 | end case; | |
00c3a3c3 NB |
417 | exception |
418 | when Err.Error => | |
419 | Err.Add_Trace_Line ("quasiquote", Ast); | |
420 | raise; | |
cbbb51b4 NB |
421 | end Quasiquote; |
422 | ||
8185fe14 | 423 | function Read return Types.T_Array |
00c3a3c3 | 424 | is (Reader.Read_Str (Readline.Input ("user> "))); |
11932a6c NB |
425 | |
426 | procedure Rep (Env : in Envs.Ptr) is | |
427 | begin | |
00c3a3c3 NB |
428 | for Expression of Read loop |
429 | Print (Eval (Expression, Env)); | |
430 | end loop; | |
11932a6c NB |
431 | end Rep; |
432 | ||
cbbb51b4 NB |
433 | ---------------------------------------------------------------------- |
434 | ||
00c3a3c3 NB |
435 | Startup : constant String |
436 | := "(def! not (fn* (a) (if a false true)))" | |
daffc668 NB |
437 | & "(def! load-file (fn* (f)" |
438 | & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" | |
439 | & "(defmacro! cond (fn* (& xs)" | |
440 | & " (if (> (count xs) 0)" | |
441 | & " (list 'if (first xs)" | |
442 | & " (if (> (count xs) 1) (nth xs 1)" | |
443 | & " (throw ""odd number of forms to cond""))" | |
444 | & " (cons 'cond (rest (rest xs)))))))" | |
14ab099c NB |
445 | & "(def! inc (fn* [x] (+ x 1)))" |
446 | & "(def! gensym (let* [counter (atom 0)]" | |
447 | & " (fn* [] (symbol (str ""G__"" (swap! counter inc))))))" | |
daffc668 NB |
448 | & "(defmacro! or (fn* (& xs)" |
449 | & " (if (empty? xs) nil" | |
450 | & " (if (= 1 (count xs)) (first xs)" | |
451 | & " (let* (condvar (gensym))" | |
452 | & " `(let* (~condvar ~(first xs))" | |
453 | & " (if ~condvar ~condvar (or ~@(rest xs)))))))))" | |
00c3a3c3 | 454 | & "(def! *host-language* ""ada.2"")"; |
5a07bb53 | 455 | Repl : constant Envs.Ptr := Envs.New_Env; |
8185fe14 | 456 | function Eval_Builtin (Args : in Types.T_Array) return Types.T is |
5a07bb53 NB |
457 | begin |
458 | Err.Check (Args'Length = 1, "expected 1 parameter"); | |
8185fe14 | 459 | return Eval (Args (Args'First), Repl); |
5a07bb53 NB |
460 | end Eval_Builtin; |
461 | Script : constant Boolean := 0 < ACL.Argument_Count; | |
8185fe14 NB |
462 | Argv : constant Types.Sequence_Ptr |
463 | := Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1)); | |
cbbb51b4 | 464 | begin |
11932a6c | 465 | -- Show the Eval function to other packages. |
8185fe14 | 466 | Types.Fns.Eval_Cb := Eval'Unrestricted_Access; |
11932a6c | 467 | -- Add Core functions into the top environment. |
5a07bb53 | 468 | Core.NS_Add_To_Repl (Repl); |
8185fe14 | 469 | Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")), |
5a07bb53 | 470 | (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); |
11932a6c | 471 | -- Native startup procedure. |
00c3a3c3 | 472 | Exec (Startup, Repl); |
11932a6c | 473 | -- Define ARGV from command line arguments. |
8185fe14 NB |
474 | for I in 2 .. ACL.Argument_Count loop |
475 | Argv.all.Data (I - 1) := (Kind_String, | |
476 | Types.Strings.Alloc (ACL.Argument (I))); | |
477 | end loop; | |
478 | Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")), | |
479 | (Kind_List, Argv)); | |
5a07bb53 NB |
480 | -- Execute user commands. |
481 | if Script then | |
482 | Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); | |
cbbb51b4 | 483 | else |
00c3a3c3 | 484 | Exec ("(println (str ""Mal ["" *host-language* ""]""))", Repl); |
11932a6c NB |
485 | loop |
486 | begin | |
487 | Rep (Repl); | |
488 | exception | |
489 | when Readline.End_Of_File => | |
490 | exit; | |
00c3a3c3 NB |
491 | when Err.Error => |
492 | Ada.Text_IO.Unbounded_IO.Put (Err.Trace); | |
11932a6c | 493 | end; |
00c3a3c3 | 494 | -- Other exceptions are really unexpected. |
5a07bb53 NB |
495 | |
496 | -- Collect garbage. | |
8185fe14 | 497 | Err.Data := Types.Nil; |
5a07bb53 NB |
498 | Repl.all.Keep; |
499 | Garbage_Collected.Clean; | |
11932a6c NB |
500 | end loop; |
501 | Ada.Text_IO.New_Line; | |
cbbb51b4 | 502 | end if; |
5a07bb53 | 503 | |
00c3a3c3 | 504 | -- If assertions are enabled, check deallocations. |
8185fe14 NB |
505 | -- Normal runs do not need to deallocate before termination. |
506 | -- Beware that all pointers are now dangling. | |
5a07bb53 NB |
507 | pragma Debug (Garbage_Collected.Clean); |
508 | Garbage_Collected.Check_Allocations; | |
cbbb51b4 | 509 | end StepA_Mal; |