12 procedure Step9_Try
is
16 function Eval
(AParam
: Types
.Mal_Handle
; AnEnv
: Envs
.Env_Handle
)
17 return Types
.Mal_Handle
;
19 Debug
: Boolean := False;
22 function Read
(Param
: String) return Types
.Mal_Handle
is
24 return Reader
.Read_Str
(Param
);
28 function Def_Fn
(Args
: List_Mal_Type
; Env
: Envs
.Env_Handle
)
30 Name
, Fn_Body
, Res
: Mal_Handle
;
33 pragma Assert
(Deref
(Name
).Sym_Type
= Sym
,
34 "Def_Fn: expected atom as name");
35 Fn_Body
:= Nth
(Args
, 1);
36 Res
:= Eval
(Fn_Body
, Env
);
37 Envs
.Set
(Env
, Deref_Sym
(Name
).Get_Sym
, Res
);
42 function Def_Macro
(Args
: List_Mal_Type
; Env
: Envs
.Env_Handle
)
44 Name
, Fn_Body
, Res
: Mal_Handle
;
45 Lambda_P
: Lambda_Ptr
;
48 pragma Assert
(Deref
(Name
).Sym_Type
= Sym
,
49 "Def_Macro: expected atom as name");
50 Fn_Body
:= Car
(Deref_List
(Cdr
(Args
)).all);
51 Res
:= Eval
(Fn_Body
, Env
);
52 Lambda_P
:= Deref_Lambda
(Res
);
53 Lambda_P
.Set_Is_Macro
(True);
54 Envs
.Set
(Env
, Deref_Sym
(Name
).Get_Sym
, Res
);
59 function Macro_Expand
(Ast
: Mal_Handle
; Env
: Envs
.Env_Handle
)
72 if Deref
(Res
).Sym_Type
/= List
then
76 LMT
:= Deref_List
(Res
).all;
78 -- Get the macro in the list from the env
79 -- or return null if not applicable.
80 LP
:= Get_Macro
(Res
, E
);
82 exit when LP
= null or else not LP
.Get_Is_Macro
;
85 Fn_List
: Mal_Handle
:= Cdr
(LMT
);
86 Params
: List_Mal_Type
;
88 E
:= Envs
.New_Env
(E
);
90 Params
:= Deref_List
(LP
.Get_Params
).all;
91 if Envs
.Bind
(E
, Params
, Deref_List
(Fn_List
).all) then
93 Res
:= Eval
(LP
.Get_Expr
, E
);
106 function Eval_As_Boolean
(MH
: Mal_Handle
) return Boolean is
109 case Deref
(MH
).Sym_Type
is
111 Res
:= Deref_Bool
(MH
).Get_Bool
;
116 -- L : List_Mal_Type;
118 -- L := Deref_List (MH).all;
119 -- Res := not Is_Null (L);
121 when others => -- Everything else
129 (Ast
: Mal_Handle
; Env
: Envs
.Env_Handle
)
132 function Call_Eval
(A
: Mal_Handle
) return Mal_Handle
is
134 return Eval
(A
, Env
);
139 case Deref
(Ast
).Sym_Type
is
144 Sym
: Mal_String
:= Deref_Sym
(Ast
).Get_Sym
;
146 -- if keyword, return it. Otherwise look it up in the environment.
150 return Envs
.Get
(Env
, Sym
);
153 when Envs
.Not_Found
=>
154 raise Envs
.Not_Found
with ("'" & Sym
& "' not found");
159 return Map
(Call_Eval
'Unrestricted_Access, Deref_List_Class
(Ast
).all);
161 when others => return Ast
;
168 function Quasi_Quote_Processing
(Param
: Mal_Handle
) return Mal_Handle
is
169 Res
, First_Elem
, FE_0
: Mal_Handle
;
171 D_Ptr
, Ast_P
: List_Class_Ptr
;
175 Ada
.Text_IO
.Put_Line
("QuasiQt " & Deref
(Param
).To_String
);
178 -- Create a New List for the result...
179 Res
:= New_List_Mal_Type
(List_List
);
180 L
:= Deref_List
(Res
);
182 -- This is the equivalent of Is_Pair
183 if Deref
(Param
).Sym_Type
/= List
or else
184 Is_Null
(Deref_List_Class
(Param
).all) then
186 -- return a new list containing: a symbol named "quote" and ast.
187 L
.Append
(New_Symbol_Mal_Type
("quote"));
193 -- Ast is a non-empty list at this point.
195 Ast_P
:= Deref_List_Class
(Param
);
197 First_Elem
:= Car
(Ast_P
.all);
199 -- if the first element of ast is a symbol named "unquote":
200 if Deref
(First_Elem
).Sym_Type
= Sym
and then
201 Deref_Sym
(First_Elem
).Get_Sym
= "unquote" then
203 -- return the second element of ast.`
204 D_Ptr
:= Deref_List_Class
(Cdr
(Ast_P
.all));
205 return Car
(D_Ptr
.all);
209 -- if the first element of first element of `ast` (`ast[0][0]`)
210 -- is a symbol named "splice-unquote"
211 if Deref
(First_Elem
).Sym_Type
= List
and then
212 not Is_Null
(Deref_List_Class
(First_Elem
).all) then
214 D_Ptr
:= Deref_List_Class
(First_Elem
);
215 FE_0
:= Car
(D_Ptr
.all);
217 if Deref
(FE_0
).Sym_Type
= Sym
and then
218 Deref_Sym
(FE_0
).Get_Sym
= "splice-unquote" then
220 -- return a new list containing: a symbol named "concat",
221 L
.Append
(New_Symbol_Mal_Type
("concat"));
223 -- the second element of first element of ast (ast[0][1]),
224 D_Ptr
:= Deref_List_Class
(Cdr
(D_Ptr
.all));
225 L
.Append
(Car
(D_Ptr
.all));
227 -- and the result of calling quasiquote with
228 -- the second through last element of ast.
229 L
.Append
(Quasi_Quote_Processing
(Cdr
(Ast_P
.all)));
237 -- otherwise: return a new list containing: a symbol named "cons",
238 L
.Append
(New_Symbol_Mal_Type
("cons"));
240 -- the result of calling quasiquote on first element of ast (ast[0]),
241 L
.Append
(Quasi_Quote_Processing
(Car
(Ast_P
.all)));
243 -- and result of calling quasiquote with the second through last element of ast.
244 L
.Append
(Quasi_Quote_Processing
(Cdr
(Ast_P
.all)));
248 end Quasi_Quote_Processing
;
251 function Catch_Processing
252 (Try_Line
: Mal_Handle
;
254 Env
: Envs
.Env_Handle
)
257 L
, CL
, CL2
, CL3
: List_Mal_Type
;
259 New_Env
: Envs
.Env_Handle
;
263 L
:= Deref_List
(Try_Line
).all;
265 -- CL is the list with the catch in.
266 CL
:= Deref_List
(C
).all;
268 CL2
:= Deref_List
(Cdr
(CL
)).all;
269 New_Env
:= Envs
.New_Env
(Env
);
270 Envs
.Set
(New_Env
, Deref_Sym
(Car
(CL2
)).Get_Sym
, ExStr
);
272 CL3
:= Deref_List
(Cdr
(CL2
)).all;
273 return Eval
(Car
(CL3
), New_Env
);
274 end Catch_Processing
;
277 function Eval
(AParam
: Mal_Handle
; AnEnv
: Envs
.Env_Handle
)
280 Env
: Envs
.Env_Handle
;
281 First_Param
, Rest_Params
: Mal_Handle
;
282 Rest_List
, Param_List
: List_Mal_Type
;
291 Ada
.Text_IO
.Put_Line
("Evaling " & Deref
(Param
).To_String
);
294 Param
:= Macro_Expand
(Param
, Env
);
297 Ada
.Text_IO
.Put_Line
("After expansion " & Deref
(Param
).To_String
);
300 if Deref
(Param
).Sym_Type
= List
and then
301 Deref_List
(Param
).Get_List_Type
= List_List
then
303 Param_List
:= Deref_List
(Param
).all;
305 -- Deal with empty list..
306 if Param_List
.Length
= 0 then
310 First_Param
:= Car
(Param_List
);
311 Rest_Params
:= Cdr
(Param_List
);
312 Rest_List
:= Deref_List
(Rest_Params
).all;
314 if Deref
(First_Param
).Sym_Type
= Sym
and then
315 Deref_Sym
(First_Param
).Get_Sym
= "def!" then
316 return Def_Fn
(Rest_List
, Env
);
317 elsif Deref
(First_Param
).Sym_Type
= Sym
and then
318 Deref_Sym
(First_Param
).Get_Sym
= "defmacro!" then
319 return Def_Macro
(Rest_List
, Env
);
320 elsif Deref
(First_Param
).Sym_Type
= Sym
and then
321 Deref_Sym
(First_Param
).Get_Sym
= "macroexpand" then
322 return Macro_Expand
(Car
(Rest_List
), Env
);
323 elsif Deref
(First_Param
).Sym_Type
= Sym
and then
324 Deref_Sym
(First_Param
).Get_Sym
= "let*" then
326 Defs
, Expr
, Res
: Mal_Handle
;
329 E
:= Envs
.New_Env
(Env
);
330 Defs
:= Car
(Rest_List
);
331 Deref_List_Class
(Defs
).Add_Defs
(E
);
332 Expr
:= Car
(Deref_List
(Cdr
(Rest_List
)).all);
337 -- Res := Eval (Expr, E);
340 elsif Deref
(First_Param
).Sym_Type
= Sym
and then
341 Deref_Sym
(First_Param
).Get_Sym
= "do" then
348 Ada
.Text_IO
.Put_Line
("Do-ing " & To_String
(Rest_List
));
351 if Is_Null
(Rest_List
) then
355 -- Loop processes Evals all but last entry
359 D
:= Deref_List
(Cdr
(D
)).all;
360 exit when Is_Null
(D
);
368 elsif Deref
(First_Param
).Sym_Type
= Sym
and then
369 Deref_Sym
(First_Param
).Get_Sym
= "if" then
371 Args
: List_Mal_Type
:= Rest_List
;
373 Cond
, True_Part
, False_Part
: Mal_Handle
;
375 pragma Assert
(Length
(Args
) = 2 or Length
(Args
) = 3,
376 "If_Processing: not 2 or 3 parameters");
380 Cond
:= Eval
(Car
(Args
), Env
);
382 Cond_Bool
:= Eval_As_Boolean
(Cond
);
385 L
:= Deref_List
(Cdr
(Args
)).all;
389 -- was: return Eval (Car (L), Env);
391 if Length
(Args
) = 3 then
392 L
:= Deref_List
(Cdr
(Args
)).all;
393 L
:= Deref_List
(Cdr
(L
)).all;
397 -- was: return Eval (Car (L), Env);
399 return New_Nil_Mal_Type
;
404 elsif Deref
(First_Param
).Sym_Type
= Sym
and then
405 Deref_Sym
(First_Param
).Get_Sym
= "fn*" then
407 return New_Lambda_Mal_Type
408 (Params
=> Car
(Rest_List
),
409 Expr
=> Nth
(Rest_List
, 1),
412 elsif Deref
(First_Param
).Sym_Type
= Sym
and then
413 Deref_Sym
(First_Param
).Get_Sym
= "quote" then
415 return Car
(Rest_List
);
417 elsif Deref
(First_Param
).Sym_Type
= Sym
and then
418 Deref_Sym
(First_Param
).Get_Sym
= "quasiquote" then
420 Param
:= Quasi_Quote_Processing
(Car
(Rest_List
));
423 elsif Deref
(First_Param
).Sym_Type
= Sym
and then
424 Deref_Sym
(First_Param
).Get_Sym
= "try*" then
429 return Eval
(Car
(Rest_List
), Env
);
431 when Mal_Exception
=>
432 Res
:= Catch_Processing
434 Types
.Mal_Exception_Value
,
436 Types
.Mal_Exception_Value
:=
437 Smart_Pointers
.Null_Smart_Pointer
;
440 return Catch_Processing
443 (Ada
.Exceptions
.Exception_Message
(E
)),
449 -- The APPLY section.
451 Evaled_H
: Mal_Handle
;
453 Evaled_H
:= Eval_Ast
(Param
, Env
);
455 Param_List
:= Deref_List
(Evaled_H
).all;
457 First_Param
:= Car
(Param_List
);
458 Rest_Params
:= Cdr
(Param_List
);
459 Rest_List
:= Deref_List
(Rest_Params
).all;
461 if Deref
(First_Param
).Sym_Type
= Func
then
462 return Call_Func
(Deref_Func
(First_Param
).all, Rest_Params
);
463 elsif Deref
(First_Param
).Sym_Type
= Lambda
then
468 Param_Names
: List_Mal_Type
;
473 L
:= Deref_Lambda
(First_Param
).all;
474 E
:= Envs
.New_Env
(L
.Get_Env
);
476 Param_Names
:= Deref_List
(L
.Get_Params
).all;
478 if Envs
.Bind
(E
, Param_Names
, Deref_List
(Rest_Params
).all) then
483 -- was: return Eval (L.Get_Expr, E);
487 raise Mal_Exception
with "Bind failed in Apply";
493 else -- neither a Lambda or a Func
501 else -- not a List_List
503 return Eval_Ast
(Param
, Env
);
510 function Print
(Param
: Types
.Mal_Handle
) return String is
512 return Printer
.Pr_Str
(Param
);
515 function Rep
(Param
: String; Env
: Envs
.Env_Handle
) return String is
516 AST
, Evaluated_AST
: Types
.Mal_Handle
;
521 if Types
.Is_Null
(AST
) then
524 Evaluated_AST
:= Eval
(AST
, Env
);
525 return Print
(Evaluated_AST
);
531 Repl_Env
: Envs
.Env_Handle
;
534 -- These two ops use Repl_Env directly.
537 procedure RE
(Str
: Mal_String
) is
538 Discarded
: Mal_Handle
;
540 Discarded
:= Eval
(Read
(Str
), Repl_Env
);
544 function Do_Eval
(Rest_Handle
: Mal_Handle
)
545 return Types
.Mal_Handle
is
546 First_Param
: Mal_Handle
;
547 Rest_List
: Types
.List_Mal_Type
;
549 Rest_List
:= Deref_List
(Rest_Handle
).all;
550 First_Param
:= Car
(Rest_List
);
551 return Eval_Callback
.Eval
.all (First_Param
, Repl_Env
);
555 Cmd_Args
, File_Param
: Natural;
556 Command_Args
: Types
.Mal_Handle
;
557 Command_List
: Types
.List_Ptr
;
558 File_Processed
: Boolean := False;
562 -- Save a function pointer back to the Eval function.
563 -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK
564 -- as we know Eval will be in scope for the lifetime of the program.
565 Eval_Callback
.Eval
:= Eval
'Unrestricted_Access;
567 Repl_Env
:= Envs
.New_Env
;
569 -- Core init also creates the first environment.
570 -- This is needed for the def!'s below.
571 Core
.Init
(Repl_Env
);
573 -- Register the eval command. This needs to be done here rather than Core.Init
574 -- as it requires direct access to Repl_Env.
575 Envs
.Set
(Repl_Env
, "eval", New_Func_Mal_Type
("eval", Do_Eval
'Unrestricted_Access));
577 RE
("(def! not (fn* (a) (if a false true)))");
578 RE
("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) "")"")))))");
579 RE
("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ""odd number of forms to cond"")) (cons 'cond (rest (rest xs)))))))");
580 RE
("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))");
583 Command_Args
:= Types
.New_List_Mal_Type
(Types
.List_List
);
584 Command_List
:= Types
.Deref_List
(Command_Args
);
586 while Ada
.Command_Line
.Argument_Count
> Cmd_Args
loop
588 Cmd_Args
:= Cmd_Args
+ 1;
589 if Ada
.Command_Line
.Argument
(Cmd_Args
) = "-d" then
591 elsif Ada
.Command_Line
.Argument
(Cmd_Args
) = "-e" then
593 elsif not File_Processed
then
594 File_Param
:= Cmd_Args
;
595 File_Processed
:= True;
598 (Types
.New_String_Mal_Type
(Ada
.Command_Line
.Argument
(Cmd_Args
)));
603 Envs
.Set
(Repl_Env
, "*ARGV*", Command_Args
);
605 if File_Processed
then
606 RE
("(load-file """ & Ada
.Command_Line
.Argument
(File_Param
) & """)");
610 Ada
.Text_IO
.Put
("user> ");
611 exit when Ada
.Text_IO
.End_Of_File
;
612 Ada
.Text_IO
.Put_Line
(Rep
(Ada
.Text_IO
.Get_Line
, Repl_Env
));
616 (Ada
.Text_IO
.Standard_Error
,
617 Ada
.Exceptions
.Exception_Information
(E
));