4 with Ada
.IO_Exceptions
;
13 procedure Step5_TCO
is
17 -- Forward declaration of Eval.
18 function Eval
(AParam
: Mal_Handle
; AnEnv
: Envs
.Env_Handle
) return Mal_Handle
;
20 Debug
: Boolean := False;
23 function Read
(Param
: String) return Types
.Mal_Handle
is
25 return Reader
.Read_Str
(Param
);
29 function Def_Fn
(Args
: List_Mal_Type
; Env
: Envs
.Env_Handle
)
31 Name
, Fn_Body
, Res
: Mal_Handle
;
34 pragma Assert
(Deref
(Name
).Sym_Type
= Sym
,
35 "Def_Fn: expected atom as name");
36 Fn_Body
:= Nth
(Args
, 1);
37 Res
:= Eval
(Fn_Body
, Env
);
38 Envs
.Set
(Env
, Deref_Sym
(Name
).Get_Sym
, Res
);
43 function Eval_As_Boolean
(MH
: Mal_Handle
) return Boolean is
46 case Deref
(MH
).Sym_Type
is
48 Res
:= Deref_Bool
(MH
).Get_Bool
;
55 -- L := Deref_List (MH).all;
56 -- Res := not Is_Null (L);
58 when others => -- Everything else
66 (Ast
: Mal_Handle
; Env
: Envs
.Env_Handle
)
69 function Call_Eval
(A
: Mal_Handle
) return Mal_Handle
is
76 case Deref
(Ast
).Sym_Type
is
81 Sym
: Mal_String
:= Deref_Sym
(Ast
).Get_Sym
;
83 -- if keyword, return it. Otherwise look it up in the environment.
87 return Envs
.Get
(Env
, Sym
);
90 when Envs
.Not_Found
=>
91 raise Envs
.Not_Found
with ("'" & Sym
& "' not found");
96 return Map
(Call_Eval
'Unrestricted_Access, Deref_List_Class
(Ast
).all);
98 when others => return Ast
;
105 function Eval
(AParam
: Mal_Handle
; AnEnv
: Envs
.Env_Handle
)
108 Env
: Envs
.Env_Handle
;
109 First_Param
, Rest_Params
: Mal_Handle
;
110 Rest_List
, Param_List
: List_Mal_Type
;
119 Ada
.Text_IO
.Put_Line
("Evaling " & Deref
(Param
).To_String
);
122 if Deref
(Param
).Sym_Type
= List
and then
123 Deref_List
(Param
).Get_List_Type
= List_List
then
125 Param_List
:= Deref_List
(Param
).all;
126 First_Param
:= Car
(Param_List
);
127 Rest_Params
:= Cdr
(Param_List
);
128 Rest_List
:= Deref_List
(Rest_Params
).all;
130 if Deref
(First_Param
).Sym_Type
= Sym
and then
131 Deref_Sym
(First_Param
).Get_Sym
= "def!" then
132 return Def_Fn
(Rest_List
, Env
);
133 elsif Deref
(First_Param
).Sym_Type
= Sym
and then
134 Deref_Sym
(First_Param
).Get_Sym
= "let*" then
136 Defs
, Expr
, Res
: Mal_Handle
;
139 E
:= Envs
.New_Env
(Env
);
140 Defs
:= Car
(Rest_List
);
141 Deref_List_Class
(Defs
).Add_Defs
(E
);
142 Expr
:= Car
(Deref_List
(Cdr
(Rest_List
)).all);
147 -- Res := Eval (Expr, E);
150 elsif Deref
(First_Param
).Sym_Type
= Sym
and then
151 Deref_Sym
(First_Param
).Get_Sym
= "do" then
158 Ada
.Text_IO
.Put_Line
("Do-ing " & To_String
(Rest_List
));
161 if Is_Null
(Rest_List
) then
165 -- Loop processes Evals all but last entry
169 D
:= Deref_List
(Cdr
(D
)).all;
170 exit when Is_Null
(D
);
178 elsif Deref
(First_Param
).Sym_Type
= Sym
and then
179 Deref_Sym
(First_Param
).Get_Sym
= "if" then
181 Args
: List_Mal_Type
:= Rest_List
;
183 Cond
, True_Part
, False_Part
: Mal_Handle
;
185 pragma Assert
(Length
(Args
) = 2 or Length
(Args
) = 3,
186 "If_Processing: not 2 or 3 parameters");
190 Cond
:= Eval
(Car
(Args
), Env
);
192 Cond_Bool
:= Eval_As_Boolean
(Cond
);
195 L
:= Deref_List
(Cdr
(Args
)).all;
199 -- was: return Eval (Car (L), Env);
201 if Length
(Args
) = 3 then
202 L
:= Deref_List
(Cdr
(Args
)).all;
203 L
:= Deref_List
(Cdr
(L
)).all;
207 -- was: return Eval (Car (L), Env);
209 return New_Nil_Mal_Type
;
214 elsif Deref
(First_Param
).Sym_Type
= Sym
and then
215 Deref_Sym
(First_Param
).Get_Sym
= "fn*" then
217 return New_Lambda_Mal_Type
218 (Params
=> Car
(Rest_List
),
219 Expr
=> Nth
(Rest_List
, 1),
224 -- The APPLY section.
226 Evaled_H
: Mal_Handle
;
228 Evaled_H
:= Eval_Ast
(Param
, Env
);
230 Param_List
:= Deref_List
(Evaled_H
).all;
232 First_Param
:= Car
(Param_List
);
233 Rest_Params
:= Cdr
(Param_List
);
234 Rest_List
:= Deref_List
(Rest_Params
).all;
236 if Deref
(First_Param
).Sym_Type
= Func
then
237 return Call_Func
(Deref_Func
(First_Param
).all, Rest_Params
);
238 elsif Deref
(First_Param
).Sym_Type
= Lambda
then
243 Param_Names
: List_Mal_Type
;
248 L
:= Deref_Lambda
(First_Param
).all;
249 E
:= Envs
.New_Env
(L
.Get_Env
);
251 Param_Names
:= Deref_List
(L
.Get_Params
).all;
253 if Envs
.Bind
(E
, Param_Names
, Deref_List
(Rest_Params
).all) then
258 -- was: return Eval (L.Get_Expr, E);
262 raise Mal_Exception
with "Bind failed in Apply";
268 else -- neither a Lambda or a Func
278 return Eval_Ast
(Param
, Env
);
285 function Print
(Param
: Types
.Mal_Handle
) return String is
287 return Printer
.Pr_Str
(Param
);
290 function Rep
(Param
: String; Env
: Envs
.Env_Handle
) return String is
291 AST
, Evaluated_AST
: Types
.Mal_Handle
;
296 if Types
.Is_Null
(AST
) then
299 Evaluated_AST
:= Eval
(AST
, Env
);
300 return Print
(Evaluated_AST
);
305 Repl_Env
: Envs
.Env_Handle
;
308 -- These two ops use Repl_Env directly.
311 procedure RE
(Str
: Mal_String
) is
312 Discarded
: Mal_Handle
;
314 Discarded
:= Eval
(Read
(Str
), Repl_Env
);
318 function Do_Eval
(Rest_Handle
: Mal_Handle
; Env
: Envs
.Env_Handle
)
319 return Types
.Mal_Handle
is
320 First_Param
: Mal_Handle
;
321 Rest_List
: Types
.List_Mal_Type
;
323 Rest_List
:= Deref_List
(Rest_Handle
).all;
324 First_Param
:= Car
(Rest_List
);
325 return Eval_Callback
.Eval
.all (First_Param
, Repl_Env
);
329 S
: String (1..Reader
.Max_Line_Len
);
335 -- Save a function pointer back to the Eval function.
336 -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK
337 -- as we know Eval will be in scope for the lifetime of the program.
338 Eval_Callback
.Eval
:= Eval
'Unrestricted_Access;
341 while Ada
.Command_Line
.Argument_Count
> Cmd_Args
loop
342 Cmd_Args
:= Cmd_Args
+ 1;
343 if Ada
.Command_Line
.Argument
(Cmd_Args
) = "-d" then
345 elsif Ada
.Command_Line
.Argument
(Cmd_Args
) = "-e" then
350 Repl_Env
:= Envs
.New_Env
;
352 Core
.Init
(Repl_Env
);
354 RE
("(def! not (fn* (a) (if a false true)))");
358 Ada
.Text_IO
.Put
("user> ");
359 Ada
.Text_IO
.Get_Line
(S
, Last
);
360 Ada
.Text_IO
.Put_Line
(Rep
(S
(1..Last
), Repl_Env
));
362 when Ada
.IO_Exceptions
.End_Error
=> raise;
365 (Ada
.Text_IO
.Standard_Error
,
366 Ada
.Exceptions
.Exception_Information
(E
));
371 when Ada
.IO_Exceptions
.End_Error
=> null;
372 -- i.e. exit without textual output