diff --git a/ada/envs.adb b/ada/envs.adb index 8e7a093f..f1fd386c 100644 --- a/ada/envs.adb +++ b/ada/envs.adb @@ -107,8 +107,9 @@ package body Envs is -- Sym and Exprs are lists. Bind Sets Keys in Syms to the corresponding - -- expression in Exprs. - procedure Bind (E : Env_Handle; Syms, Exprs : Types.List_Mal_Type) is + -- expression in Exprs. Returns true if all the parameters were bound. + function Bind (E : Env_Handle; Syms, Exprs : Types.List_Mal_Type) + return Boolean is use Types; S, Expr : List_Mal_Type; First_Sym : Atom_Ptr; @@ -116,18 +117,23 @@ package body Envs is S := Syms; Expr := Exprs; while not Is_Null (S) loop + First_Sym := Deref_Atom (Car (S)); + if First_Sym.Get_Atom = "&" then S := Deref_List (Cdr (S)).all; First_Sym := Deref_Atom (Car (S)); Set (E, First_Sym.Get_Atom, New_List_Mal_Type (Expr)); - exit; + return True; end if; + Set (E, First_Sym.Get_Atom, Car (Expr)); S := Deref_List (Cdr (S)).all; exit when Is_Null (Expr); Expr := Deref_List (Cdr (Expr)).all; + end loop; + return Is_Null (S); end Bind; diff --git a/ada/envs.ads b/ada/envs.ads index 005d188c..5f44289f 100644 --- a/ada/envs.ads +++ b/ada/envs.ads @@ -29,8 +29,9 @@ package Envs is Not_Found : exception; -- Sym and Exprs are lists. Bind Sets Keys in Syms to the corresponding - -- expression in Exprs. - procedure Bind (E : Env_Handle; Syms, Exprs : Types.List_Mal_Type); + -- expression in Exprs. Returns true if all the parameters were bound. + function Bind (E : Env_Handle; Syms, Exprs : Types.List_Mal_Type) + return Boolean; -- Create a New_Env. The previous one is pushed to the stack and the -- new one becomes the current one. diff --git a/ada/evaluation.adb b/ada/evaluation.adb index 2cc05c36..457c4445 100644 --- a/ada/evaluation.adb +++ b/ada/evaluation.adb @@ -25,7 +25,7 @@ package body Evaluation is function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is + return Mal_Handle is Name, Fn_Body, Res : Mal_Handle; begin Name := Car (Args); @@ -39,7 +39,7 @@ package body Evaluation is function Let_Processing (Args : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is + return Mal_Handle is Defs, Expr, Res : Mal_Handle; begin Envs.New_Env; @@ -76,7 +76,7 @@ package body Evaluation is function Eval_Ast (Ast : Mal_Handle; Env : Envs.Env_Handle) - return Mal_Handle is + return Mal_Handle is function Call_Eval (A : Mal_Handle) return Mal_Handle is begin @@ -131,7 +131,7 @@ package body Evaluation is function Do_Processing (Do_List : List_Mal_Type; Env : Envs.Env_Handle) - return Mal_Handle is + return Mal_Handle is D : List_Mal_Type; Res : Mal_Handle := Smart_Pointers.Null_Smart_Pointer; begin @@ -148,7 +148,7 @@ package body Evaluation is function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle) - return Mal_Handle is + return Mal_Handle is Param : Mal_Handle; Env : Envs.Env_Handle; First_Elem : Mal_Handle; @@ -157,158 +157,163 @@ package body Evaluation is Param := AParam; Env := AnEnv; - <> + <> if Debug then Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); end if; if Deref (Param).Sym_Type = List and then - Deref_List (Param).all.Get_List_Type = List_List then + Deref_List (Param).all.Get_List_Type = List_List then - declare - L : Mal_Handle := Param; - LMT, Rest_List : List_Mal_Type; - First_Elem, Rest_Handle : Mal_Handle; - begin + declare + L : Mal_Handle := Param; + LMT, Rest_List : List_Mal_Type; + First_Elem, Rest_Handle : Mal_Handle; + begin - LMT := Deref_List (L).all; + LMT := Deref_List (L).all; - First_Elem := Car (LMT); + First_Elem := Car (LMT); - Rest_Handle := Cdr (LMT); + Rest_Handle := Cdr (LMT); - Rest_List := Deref_List (Rest_Handle).all; + Rest_List := Deref_List (Rest_Handle).all; - case Deref (First_Elem).Sym_Type is + case Deref (First_Elem).Sym_Type is - when Int | Floating | Bool | Str => - - return First_Elem; + when Int | Floating | Bool | Str => + + return First_Elem; - when Atom => + when Atom => - declare - Atom_P : Atom_Ptr; - begin - Atom_P := Deref_Atom (First_Elem); - if Atom_P.Get_Atom = "def!" then - return Def_Fn (Rest_List, Env); - elsif Atom_P.Get_Atom = "let*" then - return Let_Processing (Rest_List, Env); - elsif Atom_P.Get_Atom = "do" then - return Do_Processing (Rest_List, Env); - elsif Atom_P.Get_Atom = "if" then - declare - Args : List_Mal_Type := Rest_List; + declare + Atom_P : Atom_Ptr; + begin + Atom_P := Deref_Atom (First_Elem); + if Atom_P.Get_Atom = "def!" then + return Def_Fn (Rest_List, Env); + elsif Atom_P.Get_Atom = "let*" then + return Let_Processing (Rest_List, Env); + elsif Atom_P.Get_Atom = "do" then + return Do_Processing (Rest_List, Env); + elsif Atom_P.Get_Atom = "if" then + declare + Args : List_Mal_Type := Rest_List; - Cond, True_Part, False_Part : Mal_Handle; - Cond_Bool : Boolean; - pragma Assert (Length (Args) = 2 or Length (Args) = 3, - "If_Processing: not 2 or 3 parameters"); - L : List_Mal_Type; - begin - - Cond := Eval (Car (Args), Env); + Cond, True_Part, False_Part : Mal_Handle; + Cond_Bool : Boolean; + pragma Assert (Length (Args) = 2 or Length (Args) = 3, + "If_Processing: not 2 or 3 parameters"); + L : List_Mal_Type; + begin + + Cond := Eval (Car (Args), Env); - Cond_Bool := Eval_As_Boolean (Cond); + Cond_Bool := Eval_As_Boolean (Cond); - if Cond_Bool then - L := Deref_List (Cdr (Args)).all; + if Cond_Bool then + L := Deref_List (Cdr (Args)).all; - Param := Car (L); - goto Tail_Call_Opt; - -- return Eval (Car (L), Env); + Param := Car (L); + goto Tail_Call_Opt; + -- was: return Eval (Car (L), Env); + else + if Length (Args) = 3 then + L := Deref_List (Cdr (Args)).all; + L := Deref_List (Cdr (L)).all; + + Param := Car (L); + goto Tail_Call_Opt; + -- was: return Eval (Car (L), Env); + else + return New_Atom_Mal_Type ("nil"); + end if; + end if; + end; + + else -- not a special form + + -- Apply section + declare + Res : Mal_Handle; + begin + -- Eval the atom. + Res := Eval_Ast (L, Env); + Param := Res; + goto Tail_Call_Opt; + -- was: return Eval (Res, Env); + end; + + end if; + end; + + when Func => + + return Call_Func + (Deref_Func (First_Elem).all, + Rest_Handle, + Env); + + when Lambda => + + declare + LP : Lambda_Ptr := Deref_Lambda (First_Elem); + Fn_List : Mal_Handle := Cdr (LMT); + Params : List_Mal_Type; + E : Envs.Env_Handle; + begin + E := Envs.New_Env (LP.Get_Env); + Params := Deref_List (LP.Get_Params).all; + if Envs.Bind (E, Params, Deref_List (Fn_List).all) then + + Param := LP.Get_Expr; + Env := E; + goto Tail_Call_Opt; + -- was: return Eval (LP.Get_Expr, E); + else - if Length (Args) = 3 then - L := Deref_List (Cdr (Args)).all; - L := Deref_List (Cdr (L)).all; - - Param := Car (L); - goto Tail_Call_Opt; - -- return Eval (Car (L), Env); - else - return New_Atom_Mal_Type ("nil"); - end if; + return First_Elem; end if; - end; - else -- not a special form + end; - -- Apply section - declare - Res : Mal_Handle; - begin - -- Eval the atom. - Res := Eval_Ast (L, Env); - Param := Res; - goto Tail_Call_Opt; - -- return Eval (Res, Env); - end; + when List => - end if; - end; + -- First elem in the list is a list. + -- Eval it and then insert it as first elem in the list and + -- go again. + declare + Evaled_List : Mal_Handle; + E : Envs.Env_Handle; + begin + Evaled_List := Eval (First_Elem, Env); + if Is_Null (Evaled_List) then + return Evaled_List; + elsif Deref (Evaled_List).Sym_Type = Lambda then + E := Deref_Lambda (Evaled_List).Get_Env; + else + E := Env; + end if; - when Func => + Param := Prepend (Evaled_List, Rest_List); + Env := E; + goto Tail_Call_Opt; + -- was: + -- Evaled_List := Prepend (Evaled_List, Rest_List); + -- return Eval (Evaled_List, E); + end; - return Call_Func - (Deref_Func (First_Elem).all, - Rest_Handle, - Env); + when Error => return First_Elem; - when Lambda => + when Node => return New_Error_Mal_Type ("Evaluating a node"); - declare - LP : Lambda_Ptr := Deref_Lambda (First_Elem); - Fn_List : Mal_Handle := Cdr (LMT); - Params : List_Mal_Type; - E : Envs.Env_Handle; - begin - E := Envs.New_Env (LP.Get_Env); - Params := Deref_List (LP.Get_Params).all; - Envs.Bind (E, Params, Deref_List (Fn_List).all); + when Unitary => null; -- Not yet impl - Param := LP.Get_Expr; - Env := E; - goto Tail_Call_Opt; - --return Eval (LP.Get_Expr, E); + end case; - end; - - when List => - - -- First elem in the list is a list. - -- Eval it and then insert it as first elem in the list and - -- go again. - declare - Evaled_List : Mal_Handle; - E : Envs.Env_Handle; - begin - Evaled_List := Eval (First_Elem, Env); - if Is_Null (Evaled_List) then - return Evaled_List; - elsif Deref (Evaled_List).Sym_Type = Lambda then - E := Deref_Lambda (Evaled_List).Get_Env; - else - E := Env; - end if; - - Param := Prepend (Evaled_List, Rest_List); - Env := E; - goto Tail_Call_Opt; - -- Evaled_List := Prepend (Evaled_List, Rest_List); - -- return Eval (Evaled_List, E); - end; - - when Error => return First_Elem; - - when Node => return New_Error_Mal_Type ("Evaluating a node"); - - when Unitary => null; -- Not yet impl - - end case; - - end; + end; else diff --git a/ada/smart_pointers.adb b/ada/smart_pointers.adb index cc91689c..37c7b677 100644 --- a/ada/smart_pointers.adb +++ b/ada/smart_pointers.adb @@ -30,9 +30,11 @@ package body Smart_Pointers is overriding procedure Finalize (Object : in out Smart_Pointer) is begin if Object.Pointer /= null then - Object.Pointer.Ref_Count := Object.Pointer.Ref_Count - 1; - if Object.Pointer.Ref_Count = 0 then - Free (Object.Pointer); + if Object.Pointer.Ref_Count > 0 then + Object.Pointer.Ref_Count := Object.Pointer.Ref_Count - 1; + if Object.Pointer.Ref_Count = 0 then + Free (Object.Pointer); + end if; end if; end if; end Finalize; diff --git a/ada/step5_tco.adb b/ada/step5_tco.adb index 767d87eb..23b25758 100644 --- a/ada/step5_tco.adb +++ b/ada/step5_tco.adb @@ -9,7 +9,7 @@ with Printer; with Reader; with Types; -procedure Step5_CTO is +procedure Step5_TCO is function Read (Param : String) return Types.Mal_Handle is begin @@ -78,4 +78,4 @@ begin exception when Ada.IO_Exceptions.End_Error => null; -- i.e. exit without textual output -end Step5_CTO; +end Step5_TCO; diff --git a/ada/step6_file.adb b/ada/step6_file.adb index 0c848311..1de91ee2 100644 --- a/ada/step6_file.adb +++ b/ada/step6_file.adb @@ -46,12 +46,24 @@ procedure Step6_File is Cmd_Args : Natural; Command_Args : Types.Mal_Handle; Command_List : Types.List_Ptr; + File_Processed : Boolean := False; begin - + -- Core init also creates the first environment. + -- This is needed for the def!'s below. Core.Init; + declare + Not_S : String := + Rep ("(def! not (fn* (a) (if a false true)))"); + LF_S : String := + Rep ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) "")"")))))"); + pragma Unreferenced (Not_S, LF_S); + begin + null; + end; + Cmd_Args := 0; Command_Args := Types.New_List_Mal_Type (Types.List_List); Command_List := Types.Deref_List (Command_Args); @@ -64,17 +76,26 @@ begin elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then Envs.Debug := True; else - Command_List.Append - (Types.New_Atom_Mal_Type (Ada.Command_Line.Argument (Cmd_Args))); + if not File_Processed then +-- declare +-- F_S : String := +ADa.Text_IO.Put_Line ( + Rep ("(load-file """ & Ada.Command_Line.Argument (Cmd_Args) & """)") +); +-- begin +-- null; +-- end; + File_Processed := True; + else + Command_List.Append + (Types.New_Atom_Mal_Type (Ada.Command_Line.Argument (Cmd_Args))); + end if; end if; end loop; Envs.Set (Envs.Get_Current, "*ARGV*", Command_Args); - Ada.Text_IO.Put_Line (Rep ("(def! not (fn* (a) (if a false true)))")); - Ada.Text_IO.Put_Line (Rep ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) "")"")))))")); - loop begin Ada.Text_IO.Put ("user> "); diff --git a/ada/types.adb b/ada/types.adb index 5ad4df15..d4c40799 100644 --- a/ada/types.adb +++ b/ada/types.adb @@ -804,9 +804,25 @@ package body Types is function Arith_Op (A, B : Mal_Handle) return Mal_Handle is use Types; - A_Sym_Type : Sym_Types := Deref (A).Sym_Type; - B_Sym_Type : Sym_Types := Deref (B).Sym_Type; + A_Sym_Type : Sym_Types; + B_Sym_Type : Sym_Types; begin + + if Is_Null (A) then + if Is_Null (B) then + -- both null, gotta be zero. + return New_Int_Mal_Type (0); + else -- A is null but B is not. + return Arith_Op (New_Int_Mal_Type (0), B); + end if; + elsif Is_Null (B) then + -- A is not null but B is. + return Arith_Op (A, New_Int_Mal_Type (0)); + end if; + + -- else both A and B and not null.:wq + A_Sym_Type := Deref (A).Sym_Type; + B_Sym_Type := Deref (B).Sym_Type; if A_Sym_Type = Int and B_Sym_Type = Int then return New_Int_Mal_Type (Int_Op (Deref_Int (A).Get_Int_Val, Deref_Int (B).Get_Int_Val));