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