diff --git a/ada/Makefile b/ada/Makefile index 8ce88faf..f2a43930 100644 --- a/ada/Makefile +++ b/ada/Makefile @@ -1,4 +1,4 @@ -PROGS=step0_repl step1_read_print step2_eval +PROGS=step0_repl step1_read_print step2_eval step3_env all: ${PROGS} @@ -14,5 +14,9 @@ step2_eval: step2_eval.adb types.ad[bs] reader.ad[bs] printer.ad[bs] \ smart_pointers.ad[bs] envs.ad[bs] evaluation.ad[bs] gnatmake -g -P$@ +step3_env: step3_env.adb types.ad[bs] reader.ad[bs] printer.ad[bs] \ + smart_pointers.ad[bs] envs.ad[bs] evaluation.ad[bs] + gnatmake -g -gnata -P$@ + clean: rm -f obj/* ${PROGS} diff --git a/ada/envs.adb b/ada/envs.adb index eed12c1a..ce983111 100644 --- a/ada/envs.adb +++ b/ada/envs.adb @@ -1,3 +1,4 @@ +with Ada.Text_IO; with Unchecked_Deallocation; package body Envs is @@ -11,18 +12,31 @@ package body Envs is New_Item => SP); end Set; - function Get (Key : String) return Smart_Pointers.Smart_Pointer is - use String_Mal_Hash; - C : Cursor; + + function Find (Env : Env_Ptr) return Smart_Pointers.Smart_Pointer is + use String_Mal_Hash; + C : Cursor; + begin + C := Find (Env.The_Map, + Ada.Strings.Unbounded.To_Unbounded_String (Key)); + + if C = No_Element then + + if Env.Prev_Env = null then + raise Not_Found; + else + return Find (Env.Prev_Env); + end if; + + else + return Element (C); + end if; + + end Find; + begin - C := Find (Current.The_Map, - Ada.Strings.Unbounded.To_Unbounded_String (Key)); - if C = No_Element then - raise Not_Found; - else - return Element (C); - end if; + return Find (Current); end Get; @@ -44,16 +58,24 @@ package body Envs is procedure New_Env is + Old_Env : Env_Ptr; begin + Old_Env := Current; Current := new Environment; + Current.Prev_Env := Old_Env; end New_Env; procedure Free is new Unchecked_Deallocation (Environment, Env_Ptr); procedure Delete_Env is + TBD : Env_Ptr; begin - Free (Current); + TBD := Current; + if Current.Prev_Env /= null then + Current := Current.Prev_Env; + Free (TBD); + end if; end Delete_Env; diff --git a/ada/envs.ads b/ada/envs.ads index 54053ebc..b47087a9 100644 --- a/ada/envs.ads +++ b/ada/envs.ads @@ -33,12 +33,15 @@ private Equivalent_Keys => Ada.Strings.Unbounded."=", "=" => Smart_Pointers."="); - type Environment is record - The_Map : String_Mal_Hash.Map; - end record; + type Environment; type Env_Ptr is access Environment; + type Environment is record + The_Map : String_Mal_Hash.Map; + Prev_Env : Env_Ptr; + end record; + Current : Env_Ptr; end Envs; diff --git a/ada/evaluation.adb b/ada/evaluation.adb index fcd5a5eb..2c533ecb 100644 --- a/ada/evaluation.adb +++ b/ada/evaluation.adb @@ -12,13 +12,41 @@ package body Evaluation is function "/" is new Types.Op ("/", "/"); + procedure Add_Defs (Defs : Types.List_Mal_Type) is + use Types; + Nil : Types.List_Mal_Type := Null_List (Defs.Get_List_Type); + D, L : List_Mal_Type; + begin + if Debug then + Ada.Text_IO.Put_Line ("Add_Defs " & To_String (Defs)); + end if; + D := Defs; + while D /= Nil loop + L := Deref_List (Cdr (D)).all; + Envs.Set + (Deref_Atom (Car (D)).Get_Atom, + Eval (Car (L))); + D := Deref_List (Cdr(L)).all; + end loop; + end Add_Defs; + function Apply (Func : Types.Mal_Handle; Args : Types.List_Mal_Type) return Types.Mal_Handle is use Types; begin ---Ada.Text_IO.Put_Line ("Applying " & To_String (Deref (Func).all) & " to " & Args.To_String); + + if Debug then + + Ada.Text_IO.Put_Line + ("Applying " & To_String (Deref (Func).all) & + " to " & Args.To_String); + + end if; + case Deref (Func).Sym_Type is + when Sym => + declare Sym_P : Types.Sym_Ptr; begin @@ -31,20 +59,58 @@ package body Evaluation is when others => null; end case; end; + +-- when Atom => + + when Error => return Func; + when others => null; + end case; return Smart_Pointers.Null_Smart_Pointer; end Apply; + function Def_Fn (Args : Types.List_Mal_Type) return Types.Mal_Handle is + use Types; + Name, Fn_Body, Res : Mal_Handle; + begin + Name := Car (Args); + pragma Assert (Deref (Name).Sym_Type = Atom, + "Def_Fn: expected atom as name"); + Fn_Body := Car (Deref_List (Cdr (Args)).all); + Res := Eval (Fn_Body); + Envs.Set (Deref_Atom (Name).Get_Atom, Res); + return Res; + end Def_Fn; + + + function Let_Processing (Args : Types.List_Mal_Type) + return Types.Mal_Handle is + use Types; + Defs, Expr, Res : Mal_Handle; + begin + Envs.New_Env; + Defs := Car (Args); + Add_Defs (Deref_List (Defs).all); + Expr := Car (Deref_List (Cdr (Args)).all); + Res := Eval (Expr); + Envs.Delete_Env; + return Res; + end Let_Processing; + + function Eval_Ast (Ast : Types.Mal_Handle) return Types.Mal_Handle is use Types; begin + case Deref (Ast).Sym_Type is + when Sym => + declare Sym : Mal_String (1..1) := Deref_Sym (Ast).Symbol & ""; begin @@ -53,7 +119,9 @@ package body Evaluation is when Envs.Not_Found => return New_Error_Mal_Type ("'" & Sym & "' not found"); end; + when Atom => + declare Sym : Mal_String := Deref_Atom (Ast).Get_Atom; begin @@ -67,33 +135,89 @@ package body Evaluation is when Envs.Not_Found => return New_Error_Mal_Type ("'" & Sym & "' not found"); end; + when List => + return Map (Eval'Access, Deref_List (Ast).all); - when others => - return Ast; + + when others => return Ast; + end case; + end Eval_Ast; + + function List_Processing (L : Types.Mal_Handle) + return Types.Mal_Handle is + use Types; + pragma Assert (Deref (L).Sym_Type = List, + "List_Processing: expected a list"); + Evaled_List : List_Mal_Type; + Func : Mal_Handle; + Args : List_Mal_Type; + begin + Evaled_List := Deref_List (Eval_Ast (L)).all; + Func := Car (Evaled_List); + Args := Deref_List (Cdr (Evaled_List)).all; + return Apply (Func, Args); + end List_Processing; + + + function Eval_List (L : Types.Mal_Handle) return Types.Mal_Handle is + use Types; + pragma Assert (Deref (L).Sym_Type = List, + "Eval_List: expected a List"); + LMT : List_Mal_Type; + First_Elem : Mal_Handle; + begin + + LMT := Deref_List (L).all; + + First_Elem := Car (LMT); + + if Deref (First_Elem).Sym_Type = Atom then + + declare + Atom_P : Atom_Ptr; + begin + Atom_P := Deref_Atom (First_Elem); + if Atom_P.Get_Atom = "def!" then + return Def_Fn (Deref_List (Cdr (LMT)).all); + elsif Atom_P.Get_Atom = "let*" then + return Let_Processing (Deref_List (Cdr (LMT)).all); + else -- not a special form + return List_Processing (L); + end if; + end; + + else -- First elem in list is not an atom + return List_Processing (L); + end if; + + end Eval_List; + + function Eval (Param : Types.Mal_Handle) return Types.Mal_Handle is use Types; + First_Elem : Mal_Handle; begin ---Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String); + + 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 - declare - Evaled_List : Types.List_Mal_Type; - Func : Types.Mal_Handle; - Args : Types.List_Mal_Type; - begin - Evaled_List := Deref_List (Eval_Ast (Param)).all; - Func := Types.Car (Evaled_List); - Args := Types.Cdr (Evaled_List); - return Apply (Func, Args); - end; + + return Eval_List (Param); + else + return Eval_Ast (Param); + end if; + end Eval; diff --git a/ada/evaluation.ads b/ada/evaluation.ads index 9cd63713..a71c275b 100644 --- a/ada/evaluation.ads +++ b/ada/evaluation.ads @@ -5,4 +5,8 @@ package Evaluation is function Eval (Param : Types.Mal_Handle) return Types.Mal_Handle; + Evaluation_Error : exception; + + Debug : Boolean := False; + end Evaluation; diff --git a/ada/reader.adb b/ada/reader.adb index 32f4097e..3ad49ad4 100644 --- a/ada/reader.adb +++ b/ada/reader.adb @@ -70,7 +70,7 @@ package body Reader is Body_Chars : Ada.Strings.Maps.Character_Set := Ada.Strings.Maps."or" (Ada.Strings.Maps.Constants.Alphanumeric_Set, - Ada.Strings.Maps.To_Set ("-!")); + Ada.Strings.Maps.To_Set ("-!*")); Atom_Recognizer : constant Tokenizer.Recognizable_Token := Tokenizer.Get diff --git a/ada/step3_env.adb b/ada/step3_env.adb new file mode 100644 index 00000000..c25aa67a --- /dev/null +++ b/ada/step3_env.adb @@ -0,0 +1,69 @@ +with Ada.Command_Line; +with Ada.Text_IO; +with Ada.IO_Exceptions; +with Envs; +with Evaluation; +with Printer; +with Reader; +with Types; + +procedure Step3_Env is + + function Read (Param : String) return Types.Mal_Handle is + begin + return Reader.Read_Str (Param); + end Read; + + + -- Eval can't be here because there are function pointers that point + -- at it. Thus it must be at library level. See evaluation.ads + + + function Print (Param : Types.Mal_Handle) return String is + begin + return Printer.Pr_Str (Param); + end Print; + + function Rep (Param : String) return String is + AST, Evaluated_AST : Types.Mal_Handle; + begin + + AST := Read (Param); + + if Types.Is_Null (AST) then + return ""; + else + Evaluated_AST := Evaluation.Eval (AST); + return Print (Evaluated_AST); + end if; + + end Rep; + + S : String (1..Reader.Max_Line_Len); + Last : Natural; + +begin + + if Ada.Command_Line.Argument_Count > 0 then + if Ada.Command_Line.Argument (1) = "-d" then + Evaluation.Debug := True; + end if; + end if; + + Envs.New_Env; + + Envs.Set ("+", Types.New_Sym_Mal_Type ('+')); + Envs.Set ("-", Types.New_Sym_Mal_Type ('-')); + Envs.Set ("*", Types.New_Sym_Mal_Type ('*')); + Envs.Set ("/", Types.New_Sym_Mal_Type ('/')); + + loop + Ada.Text_IO.Put ("user> "); + Ada.Text_IO.Get_Line (S, Last); + Ada.Text_IO.Put_Line (Rep (S (1..Last))); + end loop; + +exception + when Ada.IO_Exceptions.End_Error => null; + -- i.e. exit without textual output +end Step3_Env; diff --git a/ada/step3_env.gpr b/ada/step3_env.gpr new file mode 100644 index 00000000..a49dfa10 --- /dev/null +++ b/ada/step3_env.gpr @@ -0,0 +1,9 @@ +with "opentoken"; + +project Step3_Env is + + for Object_Dir use "obj"; + for Exec_Dir use "."; + for Main use ("step3_env.adb"); + +end Step3_Env; diff --git a/ada/types.adb b/ada/types.adb index 99d8bbf5..8a6ff058 100644 --- a/ada/types.adb +++ b/ada/types.adb @@ -178,7 +178,7 @@ package body Types is function Deref_Atom (S : Mal_Handle) return Atom_Ptr is begin - return Atom_Ptr (Smart_Pointers.Deref (S)); + return Atom_Ptr (Deref (S)); end Deref_Atom; overriding function To_Str (T : Atom_Mal_Type) return Mal_String is @@ -329,6 +329,26 @@ package body Types is end if; end Append; + function Node_Length (L : Mal_Handle) return Natural is + Right : Mal_Handle; + begin + if Is_Null (L) then + return 0; + else + Right := Deref_Node (L).Right; + if Is_Null (Right) then + -- Its a node; there must be something in the Left, right? ;) + return 1; + elsif Deref (Right).Sym_Type = Node then + -- Right is a node so recurse but +1 for the Left just passed. + return Node_Length (Right) + 1; + else + -- Right is not null but not node. + return 2; + end if; + end if; + end Node_Length; + -- Get the first item in the list: function Car (L : List_Mal_Type) return Mal_Handle is begin @@ -341,10 +361,11 @@ package body Types is -- Get the rest of the list (second item onwards) - function Cdr (L : List_Mal_Type) return List_Mal_Type is + function Cdr (L : List_Mal_Type) return Mal_Handle is begin - if Is_Null (L.The_List) then - return L; + if Is_Null (L.The_List) or else + Is_Null (Deref_Node (L.The_List).Right) then + return New_List_Mal_Type (L.List_Type); end if; declare Node_P : Node_Ptr; @@ -353,10 +374,22 @@ package body Types is -- Clojure lists are constants? -- If not, need to copy P.Right to a new list... -- Or maybe we copy on write? - return Deref_List (New_List_Mal_Type (L.List_Type, Node_P.Right)).all; + if Deref (Node_P.Right).Sym_Type = Node then + return New_List_Mal_Type (L.List_Type, Node_P.Right); + else + -- Right is not a Node! We'd better make one. + return New_List_Mal_Type + (L.List_Type, + New_Node_Mal_Type (Left => Node_P.Right)); + end if; end; end Cdr; + function Length (L : List_Mal_Type) return Natural is + begin + return Node_Length (L.The_List); + end Length; + function Null_List (L : List_Types) return List_Mal_Type is begin return (Mal_Type with List_Type => L, diff --git a/ada/types.ads b/ada/types.ads index 8248c2c9..6b69a255 100644 --- a/ada/types.ads +++ b/ada/types.ads @@ -156,11 +156,13 @@ package Types is procedure Append (To_List : in out List_Mal_Type; Op : Mal_Handle); + function Length (L : List_Mal_Type) return Natural; + -- Get the first item in the list: function Car (L : List_Mal_Type) return Mal_Handle; -- Get the rest of the list (second item onwards) - function Cdr (L : List_Mal_Type) return List_Mal_Type; + function Cdr (L : List_Mal_Type) return Mal_Handle; type Func_Access is access function (Elem : Mal_Handle)