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 | |
172 | for I in 2 .. Ast.Sequence.all.Length loop | |
173 | Result := Eval (Ast.Sequence.all.Data (I), Env); | |
174 | end loop; | |
175 | return Result; | |
176 | end; | |
8185fe14 NB |
177 | elsif First.Str.all = "fn*" then |
178 | Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters"); | |
179 | declare | |
180 | Params : Types.T renames Ast.Sequence.all.Data (2); | |
181 | begin | |
182 | Err.Check (Params.Kind in Types.Kind_Sequence, | |
183 | "first argument of fn* must be a sequence"); | |
184 | Env_Reusable := False; | |
185 | return Types.Fns.New_Function | |
186 | (Params => Params.Sequence, | |
187 | Ast => Ast.Sequence.all.Data (3), | |
188 | Env => Env); | |
189 | end; | |
190 | elsif First.Str.all = "macroexpand" then | |
5a07bb53 | 191 | Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); |
daffc668 | 192 | Macroexpanding := True; |
8185fe14 | 193 | Ast := Ast.Sequence.all.Data (2); |
daffc668 | 194 | goto Restart; |
8185fe14 | 195 | elsif First.Str.all = "quasiquote" then |
5a07bb53 | 196 | Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); |
8185fe14 NB |
197 | return Quasiquote (Ast.Sequence.all.Data (2), Env); |
198 | elsif First.Str.all = "try*" then | |
5a07bb53 | 199 | if Ast.Sequence.all.Length = 2 then |
8185fe14 | 200 | Ast := Ast.Sequence.all.Data (2); |
cbbb51b4 | 201 | goto Restart; |
daffc668 | 202 | end if; |
8185fe14 NB |
203 | Err.Check (Ast.Sequence.all.Length = 3 |
204 | and then Ast.Sequence.all.Data (3).Kind = Kind_List, | |
205 | "expected 1 parameter, maybe followed by a list"); | |
daffc668 | 206 | declare |
8185fe14 NB |
207 | A3 : Types.T_Array |
208 | renames Ast.Sequence.all.Data (3).Sequence.all.Data; | |
daffc668 | 209 | begin |
8185fe14 NB |
210 | Err.Check (A3'Length = 3 |
211 | and then A3 (A3'First).Kind = Kind_Symbol | |
212 | and then A3 (A3'First).Str.all = "catch*", | |
213 | "3rd parameter if present must be a catch* list"); | |
cbbb51b4 | 214 | begin |
8185fe14 | 215 | return Eval (Ast.Sequence.all.Data (2), Env); |
cbbb51b4 | 216 | exception |
5a07bb53 NB |
217 | when Err.Error => |
218 | null; | |
cbbb51b4 | 219 | end; |
8185fe14 NB |
220 | if not Env_Reusable then |
221 | Env := Envs.New_Env (Outer => Env); | |
222 | Env_Reusable := True; | |
223 | end if; | |
224 | Env.all.Set (A3 (A3'First + 1), Err.Data); -- check key kind | |
225 | Ast := A3 (A3'Last); | |
5a07bb53 | 226 | goto Restart; |
daffc668 NB |
227 | end; |
228 | else | |
a5d17b88 NB |
229 | -- Equivalent to First := Eval (First, Env) |
230 | -- except that we already know enough to spare a recursive call. | |
8185fe14 | 231 | First := Env.all.Get (First.Str); |
cbbb51b4 | 232 | end if; |
8185fe14 NB |
233 | when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key |
234 | | Kind_Macro | Types.Kind_Function => | |
a5d17b88 NB |
235 | -- Equivalent to First := Eval (First, Env) |
236 | -- except that we already know enough to spare a recursive call. | |
237 | null; | |
8185fe14 | 238 | when Types.Kind_Sequence | Kind_Map => |
a5d17b88 NB |
239 | -- Lists are definitely worth a recursion, and the two other |
240 | -- cases should be rare (they will report an error later). | |
241 | First := Eval (First, Env); | |
242 | end case; | |
243 | ||
244 | -- Apply phase. | |
245 | -- Ast is a non-empty list, | |
246 | -- First is its non-special evaluated first element. | |
247 | case First.Kind is | |
8185fe14 NB |
248 | when Kind_Macro => |
249 | -- Use the unevaluated arguments. | |
250 | if Macroexpanding then | |
251 | -- Evaluate the macro with tail call optimization. | |
252 | if not Env_Reusable then | |
253 | Env := Envs.New_Env (Outer => Env); | |
254 | Env_Reusable := True; | |
255 | end if; | |
256 | Env.all.Set_Binds | |
257 | (Binds => First.Macro.all.Params.all.Data, | |
258 | Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length)); | |
259 | Ast := First.Macro.all.Ast; | |
260 | goto Restart; | |
261 | else | |
262 | -- Evaluate the macro normally. | |
daffc668 | 263 | declare |
8185fe14 | 264 | New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env); |
daffc668 | 265 | begin |
8185fe14 NB |
266 | New_Env.all.Set_Binds |
267 | (Binds => First.Macro.all.Params.all.Data, | |
268 | Exprs => Ast.Sequence.all.Data | |
269 | (2 .. Ast.Sequence.all.Length)); | |
270 | Ast := Eval (First.Macro.all.Ast, New_Env); | |
271 | -- Then evaluate the result with TCO. | |
cbbb51b4 | 272 | goto Restart; |
daffc668 | 273 | end; |
8185fe14 NB |
274 | end if; |
275 | when Types.Kind_Function => | |
276 | null; | |
277 | when others => | |
278 | Err.Raise_With ("first element must be a function or macro"); | |
cbbb51b4 | 279 | end case; |
8185fe14 NB |
280 | -- We are applying a function. Evaluate its arguments. |
281 | declare | |
282 | Args : Types.T_Array (2 .. Ast.Sequence.all.Length); | |
283 | begin | |
284 | for I in Args'Range loop | |
285 | Args (I) := Eval (Ast.Sequence.all.Data (I), Env); | |
286 | end loop; | |
287 | case First.Kind is | |
288 | when Kind_Builtin => | |
289 | return First.Builtin.all (Args); | |
290 | when Kind_Builtin_With_Meta => | |
291 | return First.Builtin_With_Meta.all.Builtin.all (Args); | |
292 | when others => | |
293 | null; | |
294 | end case; | |
295 | -- Like Types.Fns.Apply, except that we use TCO. | |
296 | Env := Envs.New_Env (Outer => First.Fn.all.Env); | |
297 | Env_Reusable := True; | |
298 | Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data, | |
299 | Exprs => Args); | |
300 | Ast := First.Fn.all.Ast; | |
301 | goto Restart; | |
302 | end; | |
00c3a3c3 NB |
303 | exception |
304 | when Err.Error => | |
305 | if Macroexpanding then | |
306 | Err.Add_Trace_Line ("macroexpand", Ast); | |
307 | else | |
308 | Err.Add_Trace_Line ("eval", Ast); | |
309 | end if; | |
310 | raise; | |
cbbb51b4 NB |
311 | end Eval; |
312 | ||
8185fe14 NB |
313 | function Eval_Map (Source : in Types.Maps.Instance; |
314 | Env : in Envs.Ptr) return Types.T | |
315 | is | |
316 | use all type Types.Maps.Cursor; | |
317 | -- Copy the whole map so that keys are not hashed again. | |
318 | Result : constant Types.T := Types.Maps.New_Map (Source); | |
319 | Position : Types.Maps.Cursor := Result.Map.all.First; | |
320 | begin | |
321 | while Has_Element (Position) loop | |
322 | Result.Map.all.Replace_Element (Position, | |
323 | Eval (Element (Position), Env)); | |
324 | Next (Position); | |
325 | end loop; | |
326 | return Result; | |
327 | end Eval_Map; | |
328 | ||
329 | function Eval_Vector (Source : in Types.Sequences.Instance; | |
330 | Env : in Envs.Ptr) return Types.T | |
331 | is | |
332 | Ref : constant Types.Sequence_Ptr | |
333 | := Types.Sequences.Constructor (Source.Length); | |
334 | begin | |
335 | for I in Source.Data'Range loop | |
336 | Ref.all.Data (I) := Eval (Source.Data (I), Env); | |
337 | end loop; | |
338 | return (Kind_Vector, Ref); | |
339 | end Eval_Vector; | |
340 | ||
00c3a3c3 NB |
341 | procedure Exec (Script : in String; |
342 | Env : in Envs.Ptr) | |
11932a6c | 343 | is |
8185fe14 | 344 | Result : Types.T; |
cbbb51b4 | 345 | begin |
00c3a3c3 NB |
346 | for Expression of Reader.Read_Str (Script) loop |
347 | Result := Eval (Expression, Env); | |
348 | end loop; | |
11932a6c | 349 | pragma Unreferenced (Result); |
00c3a3c3 | 350 | end Exec; |
11932a6c | 351 | |
8185fe14 | 352 | procedure Print (Ast : in Types.T) is |
11932a6c NB |
353 | begin |
354 | Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast)); | |
355 | end Print; | |
cbbb51b4 | 356 | |
8185fe14 NB |
357 | function Quasiquote (Ast : in Types.T; |
358 | Env : in Envs.Ptr) return Types.T | |
6e2b7ddf | 359 | is |
cbbb51b4 | 360 | |
8185fe14 | 361 | function Quasiquote_List (List : in Types.T_Array) return Types.T; |
6e2b7ddf NB |
362 | -- Handle vectors and lists not starting with unquote. |
363 | ||
8185fe14 NB |
364 | function Quasiquote_List (List : in Types.T_Array) return Types.T is |
365 | Vector : Vectors.Vector; -- buffer for concatenation | |
366 | Tmp : Types.T; | |
6e2b7ddf | 367 | begin |
8185fe14 NB |
368 | for Elt of List loop |
369 | if Elt.Kind in Kind_List | |
370 | and then 0 < Elt.Sequence.all.Length | |
371 | and then Elt.Sequence.all.Data (1).Kind = Kind_Symbol | |
372 | and then Elt.Sequence.all.Data (1).Str.all = "splice-unquote" | |
6e2b7ddf | 373 | then |
8185fe14 | 374 | Err.Check (Elt.Sequence.all.Length = 2, |
00c3a3c3 | 375 | "splice-unquote expects 1 parameter"); |
8185fe14 | 376 | Tmp := Eval (Elt.Sequence.all.Data (2), Env); |
5a07bb53 | 377 | Err.Check (Tmp.Kind = Kind_List, |
00c3a3c3 | 378 | "splice_unquote expects a list"); |
8185fe14 NB |
379 | for Sub_Elt of Tmp.Sequence.all.Data loop |
380 | Vector.Append (Sub_Elt); | |
5a07bb53 | 381 | end loop; |
6e2b7ddf | 382 | else |
8185fe14 | 383 | Vector.Append (Quasiquote (Elt, Env)); |
daffc668 | 384 | end if; |
6e2b7ddf | 385 | end loop; |
5a07bb53 | 386 | -- Now that we know the number of elements, convert to a list. |
8185fe14 NB |
387 | declare |
388 | Sequence : constant Types.Sequence_Ptr | |
389 | := Types.Sequences.Constructor (Natural (Vector.Length)); | |
390 | begin | |
391 | for I in 1 .. Natural (Vector.Length) loop | |
392 | Sequence.all.Data (I) := Vector (I); | |
393 | end loop; | |
394 | return (Kind_List, Sequence); | |
395 | end; | |
6e2b7ddf NB |
396 | end Quasiquote_List; |
397 | ||
398 | begin -- Quasiquote | |
399 | case Ast.Kind is | |
400 | when Kind_Vector => | |
401 | -- When the test is updated, replace Kind_List with Kind_Vector. | |
8185fe14 | 402 | return Quasiquote_List (Ast.Sequence.all.Data); |
6e2b7ddf | 403 | when Kind_List => |
5a07bb53 | 404 | if 0 < Ast.Sequence.all.Length |
8185fe14 NB |
405 | and then Ast.Sequence.all.Data (1).Kind = Kind_Symbol |
406 | and then Ast.Sequence.all.Data (1).Str.all = "unquote" | |
6e2b7ddf | 407 | then |
5a07bb53 | 408 | Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter"); |
8185fe14 | 409 | return Eval (Ast.Sequence.all.Data (2), Env); |
6e2b7ddf | 410 | else |
8185fe14 | 411 | return Quasiquote_List (Ast.Sequence.all.Data); |
daffc668 | 412 | end if; |
6e2b7ddf NB |
413 | when others => |
414 | return Ast; | |
415 | end case; | |
00c3a3c3 NB |
416 | exception |
417 | when Err.Error => | |
418 | Err.Add_Trace_Line ("quasiquote", Ast); | |
419 | raise; | |
cbbb51b4 NB |
420 | end Quasiquote; |
421 | ||
8185fe14 | 422 | function Read return Types.T_Array |
00c3a3c3 | 423 | is (Reader.Read_Str (Readline.Input ("user> "))); |
11932a6c NB |
424 | |
425 | procedure Rep (Env : in Envs.Ptr) is | |
426 | begin | |
00c3a3c3 NB |
427 | for Expression of Read loop |
428 | Print (Eval (Expression, Env)); | |
429 | end loop; | |
11932a6c NB |
430 | end Rep; |
431 | ||
cbbb51b4 NB |
432 | ---------------------------------------------------------------------- |
433 | ||
00c3a3c3 NB |
434 | Startup : constant String |
435 | := "(def! not (fn* (a) (if a false true)))" | |
daffc668 NB |
436 | & "(def! load-file (fn* (f)" |
437 | & " (eval (read-string (str ""(do "" (slurp f) "")"")))))" | |
438 | & "(defmacro! cond (fn* (& xs)" | |
439 | & " (if (> (count xs) 0)" | |
440 | & " (list 'if (first xs)" | |
441 | & " (if (> (count xs) 1) (nth xs 1)" | |
442 | & " (throw ""odd number of forms to cond""))" | |
443 | & " (cons 'cond (rest (rest xs)))))))" | |
14ab099c NB |
444 | & "(def! inc (fn* [x] (+ x 1)))" |
445 | & "(def! gensym (let* [counter (atom 0)]" | |
446 | & " (fn* [] (symbol (str ""G__"" (swap! counter inc))))))" | |
daffc668 NB |
447 | & "(defmacro! or (fn* (& xs)" |
448 | & " (if (empty? xs) nil" | |
449 | & " (if (= 1 (count xs)) (first xs)" | |
450 | & " (let* (condvar (gensym))" | |
451 | & " `(let* (~condvar ~(first xs))" | |
452 | & " (if ~condvar ~condvar (or ~@(rest xs)))))))))" | |
00c3a3c3 | 453 | & "(def! *host-language* ""ada.2"")"; |
5a07bb53 | 454 | Repl : constant Envs.Ptr := Envs.New_Env; |
8185fe14 | 455 | function Eval_Builtin (Args : in Types.T_Array) return Types.T is |
5a07bb53 NB |
456 | begin |
457 | Err.Check (Args'Length = 1, "expected 1 parameter"); | |
8185fe14 | 458 | return Eval (Args (Args'First), Repl); |
5a07bb53 NB |
459 | end Eval_Builtin; |
460 | Script : constant Boolean := 0 < ACL.Argument_Count; | |
8185fe14 NB |
461 | Argv : constant Types.Sequence_Ptr |
462 | := Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1)); | |
cbbb51b4 | 463 | begin |
11932a6c | 464 | -- Show the Eval function to other packages. |
8185fe14 | 465 | Types.Fns.Eval_Cb := Eval'Unrestricted_Access; |
11932a6c | 466 | -- Add Core functions into the top environment. |
5a07bb53 | 467 | Core.NS_Add_To_Repl (Repl); |
8185fe14 | 468 | Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")), |
5a07bb53 | 469 | (Kind_Builtin, Eval_Builtin'Unrestricted_Access)); |
11932a6c | 470 | -- Native startup procedure. |
00c3a3c3 | 471 | Exec (Startup, Repl); |
11932a6c | 472 | -- Define ARGV from command line arguments. |
8185fe14 NB |
473 | for I in 2 .. ACL.Argument_Count loop |
474 | Argv.all.Data (I - 1) := (Kind_String, | |
475 | Types.Strings.Alloc (ACL.Argument (I))); | |
476 | end loop; | |
477 | Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")), | |
478 | (Kind_List, Argv)); | |
5a07bb53 NB |
479 | -- Execute user commands. |
480 | if Script then | |
481 | Exec ("(load-file """ & ACL.Argument (1) & """)", Repl); | |
cbbb51b4 | 482 | else |
00c3a3c3 | 483 | Exec ("(println (str ""Mal ["" *host-language* ""]""))", Repl); |
11932a6c NB |
484 | loop |
485 | begin | |
486 | Rep (Repl); | |
487 | exception | |
488 | when Readline.End_Of_File => | |
489 | exit; | |
00c3a3c3 NB |
490 | when Err.Error => |
491 | Ada.Text_IO.Unbounded_IO.Put (Err.Trace); | |
11932a6c | 492 | end; |
00c3a3c3 | 493 | -- Other exceptions are really unexpected. |
5a07bb53 NB |
494 | |
495 | -- Collect garbage. | |
8185fe14 | 496 | Err.Data := Types.Nil; |
5a07bb53 NB |
497 | Repl.all.Keep; |
498 | Garbage_Collected.Clean; | |
11932a6c NB |
499 | end loop; |
500 | Ada.Text_IO.New_Line; | |
cbbb51b4 | 501 | end if; |
5a07bb53 | 502 | |
00c3a3c3 | 503 | -- If assertions are enabled, check deallocations. |
8185fe14 NB |
504 | -- Normal runs do not need to deallocate before termination. |
505 | -- Beware that all pointers are now dangling. | |
5a07bb53 NB |
506 | pragma Debug (Garbage_Collected.Clean); |
507 | Garbage_Collected.Check_Allocations; | |
cbbb51b4 | 508 | end StepA_Mal; |