[jackhill/mal.git] / ada / step5_tco.adb

with Ada.Command_Line;
with Ada.Exceptions;
with Ada.Text_IO;
with Ada.IO_Exceptions;
with Core;
with Envs;
with Eval_Callback;
with Printer;
with Reader;
with Smart_Pointers;
with Types;

procedure Step5_TCO is

   use Types;

   function Read (Param : String) return Types.Mal_Handle is
   begin
      return Reader.Read_Str (Param);
   end Read;


   -- evaluation.ads

   function Eval (AParam : Types.Mal_Handle; AnEnv : Envs.Env_Handle)
   return Types.Mal_Handle;

   Debug : Boolean := False;


   -- evaluation.adb

   function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle)
		   return Mal_Handle is
      Name, Fn_Body, Res : Mal_Handle;
   begin
      Name := Car (Args);
      pragma Assert (Deref (Name).Sym_Type = Sym,
                     "Def_Fn: expected atom as name");
      Fn_Body := Car (Deref_List (Cdr (Args)).all);
      Res := Eval (Fn_Body, Env);
      Envs.Set (Envs.Get_Current, Deref_Sym (Name).Get_Sym, Res);
      return Res;
   end Def_Fn;


   function Eval_As_Boolean (MH : Mal_Handle) return Boolean is
      Res : Boolean;
   begin
      case Deref (MH).Sym_Type is
         when Bool => 
            Res := Deref_Bool (MH).Get_Bool;
         when Sym =>
            return not (Deref_Sym (MH).Get_Sym = "nil");
--         when List =>
--            declare
--               L : List_Mal_Type;
--            begin
--               L := Deref_List (MH).all;
--               Res := not Is_Null (L);
--            end;
         when others => -- Everything else
            Res := True;
      end case;
      return Res;
   end Eval_As_Boolean;


   function Eval_Ast
     (Ast : Mal_Handle; Env : Envs.Env_Handle)
     return Mal_Handle is

      function Call_Eval (A : Mal_Handle) return Mal_Handle is
      begin
         return Eval (A, Env);
      end Call_Eval;

   begin

      case Deref (Ast).Sym_Type is

         when Sym =>

            declare
               Sym : Mal_String := Deref_Sym (Ast).Get_Sym;
            begin
               -- if keyword, return it. Otherwise look it up in the environment.
               if Sym(1) = ':' then
                  return Ast;
               else
                  return Envs.Get (Env, Sym);
               end if;
            exception
               when Envs.Not_Found =>
                  raise Envs.Not_Found with (" '" &  Sym & "' not found ");
            end;

         when List =>

            return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);

         when Lambda =>

            -- Evaluating a lambda in a different Env.
            declare
               L : Lambda_Ptr;
               New_Env : Envs.Env_Handle;
            begin
               L := Deref_Lambda (Ast);
               New_Env := Env;
               -- Make the current Lambda's env the outer of the env param.
               Envs.Set_Outer (New_Env, L.Get_Env);
               -- Make the Lambda's Env.
               L.Set_Env (New_Env);
               return Ast;
            end;

         when others => return Ast;

      end case;

   end Eval_Ast;


   function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle)
		 return Mal_Handle is
      Param : Mal_Handle;
      Env : Envs.Env_Handle;
      First_Param, Rest_Params : Mal_Handle;
      Rest_List, Param_List : List_Mal_Type;
   begin

      Param := AParam;
      Env := AnEnv;

  <<Tail_Call_Opt>>

      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).Get_List_Type = List_List then

         Param_List := Deref_List (Param).all;
         First_Param := Car (Param_List);
         Rest_Params := Cdr (Param_List);
         Rest_List := Deref_List (Rest_Params).all;

         if Deref (First_Param).Sym_Type = Sym and then
            Deref_Sym (First_Param).Get_Sym = "def!" then
 	    return Def_Fn (Rest_List, Env);
         elsif Deref (First_Param).Sym_Type = Sym and then
               Deref_Sym (First_Param).Get_Sym = "let*" then
            declare
               Defs, Expr, Res : Mal_Handle;
               E : Envs.Env_Handle;
            begin
               E := Envs.New_Env (Env);
               Defs := Car (Rest_List);
               Deref_List_Class (Defs).Add_Defs (E);
               Expr := Car (Deref_List (Cdr (Rest_List)).all);
	       Param := Expr;
	       Env := E;
	       goto Tail_Call_Opt;
               -- was:
               -- Res := Eval (Expr, E);
               -- return Res;
            end;
         elsif Deref (First_Param).Sym_Type = Sym and then
               Deref_Sym (First_Param).Get_Sym = "do" then
            declare
               D : List_Mal_Type;
               E : Mal_Handle;
            begin

               if Debug then
                  Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List));
               end if;

               if Is_Null (Rest_List) then
                  return Rest_Params;
               end if;

               -- Loop processes Evals all but last entry
               D := Rest_List;
               loop
                  E := Car (D);
                  D := Deref_List (Cdr (D)).all;
               exit when Is_Null (D);
                  E := Eval (E, Env);
               end loop;

               Param := E;
               goto Tail_Call_Opt;

            end;
         elsif Deref (First_Param).Sym_Type = Sym and then
               Deref_Sym (First_Param).Get_Sym = "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_Bool := Eval_As_Boolean (Cond);

	       if Cond_Bool then
	          L := Deref_List (Cdr (Args)).all;

	          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_Symbol_Mal_Type ("nil");
	          end if;
	       end if;
	    end;

         elsif Deref (First_Param).Sym_Type = Sym and then
               Deref_Sym (First_Param).Get_Sym = "fn*" then

            return New_Lambda_Mal_Type
                     (Params => Car (Rest_List),
                      Expr => Nth (Rest_List, 1),
                      Env => Env);

         else

            -- The APPLY section.
            declare
               Evaled_H : Mal_Handle;
            begin
               Evaled_H := Eval_Ast (Param, Env);

               Param_List := Deref_List (Evaled_H).all;

               First_Param := Car (Param_List);
               Rest_Params := Cdr (Param_List);
               Rest_List := Deref_List (Rest_Params).all;

               if Deref (First_Param).Sym_Type = Func then
                  return Call_Func (Deref_Func (First_Param).all, Rest_Params, Env);
               elsif Deref (First_Param).Sym_Type = Lambda then
                  declare

                     L : Lambda_Mal_Type;
                     E : Envs.Env_Handle;
                     Param_Names : List_Mal_Type;
                     Res : Mal_Handle;

                  begin

                     L := Deref_Lambda (First_Param).all;
                     E := Envs.New_Env (L.Get_Env);

                     Param_Names := Deref_List (L.Get_Params).all;

                     if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then

			Param := L.Get_Expr;
                        Env := E;
			goto Tail_Call_Opt;
                        -- was: return Eval (L.Get_Expr, E); 

                     else

                        raise Mal_Exception with "Bind failed in Apply";

                     end if;

                  end;

               else  -- neither a Lambda or a Func
                  raise Mal_Exception;
               end if;

            end;

         end if;

      else

         return Eval_Ast (Param, Env);

      end if;

   end Eval;


   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 := Eval (AST, Envs.Get_Current);
        return Print (Evaluated_AST);
     end if;

   end Rep; 

   S : String (1..Reader.Max_Line_Len);
   Last : Natural;
   Cmd_Args : Natural;

begin

   Cmd_Args := 0;
   while Ada.Command_Line.Argument_Count > Cmd_Args loop
     Cmd_Args := Cmd_Args + 1;
     if Ada.Command_Line.Argument (Cmd_Args) = "-d" then
        Debug := True;
     elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then
        Envs.Debug := True;
     end if;
   end loop;

   -- Save a function pointer back to the Eval function.
   -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK
   -- as we know Eval will be in scope for the lifetime of the program.
   Eval_Callback.Eval := Eval'Unrestricted_Access;

   Core.Init;

   Ada.Text_IO.Put_Line (Rep ("(def! not (fn* (a) (if a false true)))"));

   loop
      begin
         Ada.Text_IO.Put ("user> ");
         Ada.Text_IO.Get_Line (S, Last);
         Ada.Text_IO.Put_Line (Rep (S (1..Last)));
      exception
         when Ada.IO_Exceptions.End_Error => raise;
         when E : others =>
            Ada.Text_IO.Put_Line
              (Ada.Text_IO.Standard_Error,
               Ada.Exceptions.Exception_Information (E));
      end;
   end loop;

exception
   when Ada.IO_Exceptions.End_Error => null;
   -- i.e. exit without textual output
end Step5_TCO;
Commit	Line	Data
a3c4ba44 CM	1	with Ada.Command_Line;
	2	with Ada.Exceptions;
	3	with Ada.Text_IO;
	4	with Ada.IO_Exceptions;
	5	with Core;
	6	with Envs;
18e21187	7	with Eval_Callback;
a3c4ba44 CM	8	with Printer;
a3c4ba44 CM	9	with Reader;
18e21187	10	with Smart_Pointers;
a3c4ba44 CM	11	with Types;
a3c4ba44 CM	12
c3244bcf	13	procedure Step5_TCO is
a3c4ba44	14
18e21187 CM	15	use Types;
18e21187 CM	16
a3c4ba44 CM	17	function Read (Param : String) return Types.Mal_Handle is
	18	begin
	19	return Reader.Read_Str (Param);
	20	end Read;
	21
	22
18e21187 CM	23	-- evaluation.ads
	24
	25	function Eval (AParam : Types.Mal_Handle; AnEnv : Envs.Env_Handle)
	26	return Types.Mal_Handle;
	27
	28	Debug : Boolean := False;
	29
	30
	31	-- evaluation.adb
	32
	33	function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle)
	34	return Mal_Handle is
	35	Name, Fn_Body, Res : Mal_Handle;
	36	begin
	37	Name := Car (Args);
	38	pragma Assert (Deref (Name).Sym_Type = Sym,
	39	"Def_Fn: expected atom as name");
	40	Fn_Body := Car (Deref_List (Cdr (Args)).all);
	41	Res := Eval (Fn_Body, Env);
	42	Envs.Set (Envs.Get_Current, Deref_Sym (Name).Get_Sym, Res);
	43	return Res;
	44	end Def_Fn;
	45
	46
	47	function Eval_As_Boolean (MH : Mal_Handle) return Boolean is
	48	Res : Boolean;
	49	begin
	50	case Deref (MH).Sym_Type is
	51	when Bool =>
	52	Res := Deref_Bool (MH).Get_Bool;
	53	when Sym =>
	54	return not (Deref_Sym (MH).Get_Sym = "nil");
	55	-- when List =>
	56	-- declare
	57	-- L : List_Mal_Type;
	58	-- begin
	59	-- L := Deref_List (MH).all;
	60	-- Res := not Is_Null (L);
	61	-- end;
	62	when others => -- Everything else
	63	Res := True;
	64	end case;
	65	return Res;
	66	end Eval_As_Boolean;
	67
	68
	69	function Eval_Ast
	70	(Ast : Mal_Handle; Env : Envs.Env_Handle)
	71	return Mal_Handle is
	72
	73	function Call_Eval (A : Mal_Handle) return Mal_Handle is
	74	begin
	75	return Eval (A, Env);
	76	end Call_Eval;
	77
	78	begin
	79
	80	case Deref (Ast).Sym_Type is
	81
	82	when Sym =>
	83
	84	declare
	85	Sym : Mal_String := Deref_Sym (Ast).Get_Sym;
	86	begin
87	-- if keyword, return it. Otherwise look it up in the environment.
88	if Sym(1) = ':' then
89	return Ast;
90	else
91	return Envs.Get (Env, Sym);
92	end if;
93	exception
94	when Envs.Not_Found =>
95	raise Envs.Not_Found with (" '" & Sym & "' not found ");
96	end;
97
98	when List =>
99
100	return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
101
102	when Lambda =>
103
104	-- Evaluating a lambda in a different Env.
105	declare
106	L : Lambda_Ptr;
107	New_Env : Envs.Env_Handle;
108	begin
109	L := Deref_Lambda (Ast);
110	New_Env := Env;
111	-- Make the current Lambda's env the outer of the env param.
112	Envs.Set_Outer (New_Env, L.Get_Env);
113	-- Make the Lambda's Env.
114	L.Set_Env (New_Env);
115	return Ast;
116	end;
117
118	when others => return Ast;
119
120	end case;
121
122	end Eval_Ast;
123
124
125	function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle)
126	return Mal_Handle is
127	Param : Mal_Handle;
128	Env : Envs.Env_Handle;
129	First_Param, Rest_Params : Mal_Handle;
130	Rest_List, Param_List : List_Mal_Type;
131	begin
132
133	Param := AParam;
134	Env := AnEnv;
135
136	<<Tail_Call_Opt>>
137
138	if Debug then
139	Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
140	end if;
141
142	if Deref (Param).Sym_Type = List and then
143	Deref_List (Param).Get_List_Type = List_List then
144
145	Param_List := Deref_List (Param).all;
146	First_Param := Car (Param_List);
147	Rest_Params := Cdr (Param_List);
148	Rest_List := Deref_List (Rest_Params).all;
149
150	if Deref (First_Param).Sym_Type = Sym and then
151	Deref_Sym (First_Param).Get_Sym = "def!" then
152	return Def_Fn (Rest_List, Env);
153	elsif Deref (First_Param).Sym_Type = Sym and then
154	Deref_Sym (First_Param).Get_Sym = "let*" then
155	declare
156	Defs, Expr, Res : Mal_Handle;
157	E : Envs.Env_Handle;
158	begin
159	E := Envs.New_Env (Env);
160	Defs := Car (Rest_List);
161	Deref_List_Class (Defs).Add_Defs (E);
162	Expr := Car (Deref_List (Cdr (Rest_List)).all);
163	Param := Expr;
164	Env := E;
165	goto Tail_Call_Opt;
166	-- was:
167	-- Res := Eval (Expr, E);
168	-- return Res;
169	end;
170	elsif Deref (First_Param).Sym_Type = Sym and then
171	Deref_Sym (First_Param).Get_Sym = "do" then
172	declare
173	D : List_Mal_Type;
174	E : Mal_Handle;
175	begin
176
177	if Debug then
178	Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List));
179	end if;
180
181	if Is_Null (Rest_List) then
182	return Rest_Params;
183	end if;
184
185	-- Loop processes Evals all but last entry
186	D := Rest_List;
187	loop
188	E := Car (D);
189	D := Deref_List (Cdr (D)).all;
190	exit when Is_Null (D);
191	E := Eval (E, Env);
192	end loop;
193
194	Param := E;
195	goto Tail_Call_Opt;
196
197	end;
198	elsif Deref (First_Param).Sym_Type = Sym and then
199	Deref_Sym (First_Param).Get_Sym = "if" then
200	declare
201	Args : List_Mal_Type := Rest_List;
202
203	Cond, True_Part, False_Part : Mal_Handle;
204	Cond_Bool : Boolean;
205	pragma Assert (Length (Args) = 2 or Length (Args) = 3,
206	"If_Processing: not 2 or 3 parameters");
207	L : List_Mal_Type;
208	begin
209
210	Cond := Eval (Car (Args), Env);
211
212	Cond_Bool := Eval_As_Boolean (Cond);
213
214	if Cond_Bool then
215	L := Deref_List (Cdr (Args)).all;
216
217	Param := Car (L);
218	goto Tail_Call_Opt;
219	-- was: return Eval (Car (L), Env);
220	else
221	if Length (Args) = 3 then
222	L := Deref_List (Cdr (Args)).all;
223	L := Deref_List (Cdr (L)).all;
224
225	Param := Car (L);
226	goto Tail_Call_Opt;
227	-- was: return Eval (Car (L), Env);
228	else
229	return New_Symbol_Mal_Type ("nil");
230	end if;
231	end if;
232	end;
233
234	elsif Deref (First_Param).Sym_Type = Sym and then
235	Deref_Sym (First_Param).Get_Sym = "fn*" then
236
237	return New_Lambda_Mal_Type
238	(Params => Car (Rest_List),
239	Expr => Nth (Rest_List, 1),
240	Env => Env);
241
242	else
243
244	-- The APPLY section.
245	declare
246	Evaled_H : Mal_Handle;
247	begin
248	Evaled_H := Eval_Ast (Param, Env);
249
250	Param_List := Deref_List (Evaled_H).all;
251
252	First_Param := Car (Param_List);
253	Rest_Params := Cdr (Param_List);
254	Rest_List := Deref_List (Rest_Params).all;
255
256	if Deref (First_Param).Sym_Type = Func then
257	return Call_Func (Deref_Func (First_Param).all, Rest_Params, Env);
258	elsif Deref (First_Param).Sym_Type = Lambda then
259	declare
260
261	L : Lambda_Mal_Type;
262	E : Envs.Env_Handle;
263	Param_Names : List_Mal_Type;
264	Res : Mal_Handle;
265
266	begin
267
268	L := Deref_Lambda (First_Param).all;
269	E := Envs.New_Env (L.Get_Env);
270
271	Param_Names := Deref_List (L.Get_Params).all;
272
273	if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then
274
275	Param := L.Get_Expr;
276	Env := E;
277	goto Tail_Call_Opt;
278	-- was: return Eval (L.Get_Expr, E);
279
280	else
281
282	raise Mal_Exception with "Bind failed in Apply";
283
284	end if;
285
286	end;
287
288	else -- neither a Lambda or a Func
289	raise Mal_Exception;
290	end if;
291
292	end;
293
294	end if;
295
296	else
297
298	return Eval_Ast (Param, Env);
299
300	end if;
301
302	end Eval;
a3c4ba44 CM	303
	304
	305	function Print (Param : Types.Mal_Handle) return String is
	306	begin
	307	return Printer.Pr_Str (Param);
	308	end Print;
	309
	310	function Rep (Param : String) return String is
	311	AST, Evaluated_AST : Types.Mal_Handle;
	312	begin
	313
	314	AST := Read (Param);
	315
	316	if Types.Is_Null (AST) then
	317	return "";
	318	else
18e21187	319	Evaluated_AST := Eval (AST, Envs.Get_Current);
a3c4ba44 CM	320	return Print (Evaluated_AST);
	321	end if;
	322
	323	end Rep;
	324
	325	S : String (1..Reader.Max_Line_Len);
	326	Last : Natural;
	327	Cmd_Args : Natural;
	328
	329	begin
	330
	331	Cmd_Args := 0;
	332	while Ada.Command_Line.Argument_Count > Cmd_Args loop
	333	Cmd_Args := Cmd_Args + 1;
	334	if Ada.Command_Line.Argument (Cmd_Args) = "-d" then
18e21187	335	Debug := True;
a3c4ba44 CM	336	elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then
	337	Envs.Debug := True;
	338	end if;
	339	end loop;
	340
18e21187 CM	341	-- Save a function pointer back to the Eval function.
	342	-- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK
	343	-- as we know Eval will be in scope for the lifetime of the program.
	344	Eval_Callback.Eval := Eval'Unrestricted_Access;
	345
a3c4ba44 CM	346	Core.Init;
	347
	348	Ada.Text_IO.Put_Line (Rep ("(def! not (fn* (a) (if a false true)))"));
	349
	350	loop
	351	begin
	352	Ada.Text_IO.Put ("user> ");
	353	Ada.Text_IO.Get_Line (S, Last);
	354	Ada.Text_IO.Put_Line (Rep (S (1..Last)));
	355	exception
	356	when Ada.IO_Exceptions.End_Error => raise;
	357	when E : others =>
	358	Ada.Text_IO.Put_Line
	359	(Ada.Text_IO.Standard_Error,
	360	Ada.Exceptions.Exception_Information (E));
	361	end;
	362	end loop;
	363
	364	exception
	365	when Ada.IO_Exceptions.End_Error => null;
	366	-- i.e. exit without textual output
c3244bcf	367	end Step5_TCO;