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

with Ada.Text_IO;
with Ada.Exceptions;
with Envs;
with Smart_Pointers;

package body Evaluation is

   use Types;

   procedure Add_Defs (Defs : List_Mal_Type; Env : Envs.Env_Handle) is
      D, L : List_Mal_Type;
   begin
      if Debug then
         Ada.Text_IO.Put_Line ("Add_Defs " & To_String (Defs));
      end if;
      D := Defs;
      while not Is_Null (D) loop
         L := Deref_List (Cdr (D)).all;
         Envs.Set
           (Env,
            Deref_Atom (Car (D)).Get_Atom,
            Eval (Car (L), Env));
         D := Deref_List (Cdr(L)).all;
      end loop;
   end Add_Defs;


   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 = Atom,
                     "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_Atom (Name).Get_Atom, Res);
      return Res;
   end Def_Fn;


   function Def_Macro (Args : List_Mal_Type; Env : Envs.Env_Handle)
		   return Mal_Handle is
      Name, Fn_Body, Res : Mal_Handle;
      Lambda_P : Lambda_Ptr;
   begin
      Name := Car (Args);
      pragma Assert (Deref (Name).Sym_Type = Atom,
                     "Def_Macro: expected atom as name");
      Fn_Body := Car (Deref_List (Cdr (Args)).all);
      Res := Eval (Fn_Body, Env);
      Lambda_P := Deref_Lambda (Res);
      Lambda_P.Set_Is_Macro (True);
      Envs.Set (Envs.Get_Current, Deref_Atom (Name).Get_Atom, Res);
      return Res;
   end Def_Macro;


   function Macro_Expand (Ast : Mal_Handle; Env : Envs.Env_Handle)
   return Mal_Handle is
      Res : Mal_Handle;
      E : Envs.Env_Handle;
      LMT : List_Mal_Type;
      LP : Lambda_Ptr;
   begin

      Res := Ast;
      E := Env;

      loop

         if Deref (Res).Sym_Type /= List then
            exit;
         end if;

         LMT := Deref_List (Res).all;

         -- Get the macro in the list from the env
         -- or return null if not applicable.
         LP := Get_Macro (Res, E);

      exit when LP = null or else not LP.Get_Is_Macro;

	  declare
	     Fn_List : Mal_Handle := Cdr (LMT);
	     Params : List_Mal_Type;
	  begin
	     E := Envs.New_Env (E);

	     Params := Deref_List (LP.Get_Params).all;
	     if Envs.Bind (E, Params, Deref_List (Fn_List).all) then

	        Res := Eval (LP.Get_Expr, E); 
      
             end if;

	  end;

      end loop;

      return Res;

   end Macro_Expand;


   function Let_Processing (Args : List_Mal_Type; Env : Envs.Env_Handle)
			   return Mal_Handle is
      Defs, Expr, Res : Mal_Handle;
      E : Envs.Env_Handle;
   begin
      E := Envs.New_Env (Env);
      Defs := Car (Args);
      Add_Defs (Deref_List (Defs).all, E);
      Expr := Car (Deref_List (Cdr (Args)).all);
      Res := Eval (Expr, E);
      return Res;
   end Let_Processing;


   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 Atom =>
            return not (Deref_Atom (MH).Get_Atom = "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 Atom =>

            declare
               Sym : Mal_String := Deref_Atom (Ast).Get_Atom;
            begin
               -- if keyword or nil (which may represent False)...
               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 (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 Do_Processing (Do_List : List_Mal_Type; Env : Envs.Env_Handle)
			  return Mal_Handle is
      D : List_Mal_Type;
      Res : Mal_Handle := Smart_Pointers.Null_Smart_Pointer;
   begin
      if Debug then
         Ada.Text_IO.Put_Line ("Do-ing " & To_String (Do_List));
      end if;
      D := Do_List;
      while not Is_Null (D) loop
         Res := Eval (Car (D), Env);
         D := Deref_List (Cdr(D)).all;
      end loop;
      return Res;
   end Do_Processing;


   function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is
      Res, First_Elem, FE_0 : Mal_Handle;
      D, Ast : List_Mal_Type;
      L : List_Ptr;
   begin

      if Debug then
         Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String);
      end if;

      -- Create a New List for the result...
      Res := New_List_Mal_Type (List_List);
      L := Deref_List (Res);

      -- This is the equivalent of Is_Pair
      if Deref (Param).Sym_Type /= List or else
         Is_Null (Deref_List (Param).all) then

         -- return a new list containing: a symbol named "quote" and ast.
         L.Append (New_Atom_Mal_Type ("quote"));
         L.Append (Param);
         return Res;

      end if;

      -- Ast is a non-empty list at this point.

      Ast := Deref_List (Param).all;

      First_Elem := Car (Ast);

      -- if the first element of ast is a symbol named "unquote":
      if Deref (First_Elem).Sym_Type = Atom and then
         Deref_Atom (First_Elem).Get_Atom = "unquote" then

         -- return the second element of ast.`
         D := Deref_List (Cdr (Ast)).all;
         return Car (D);

      end if;

      -- if the first element of first element of `ast` (`ast[0][0]`)
      -- is a symbol named "splice-unquote"
      if Deref (First_Elem).Sym_Type = List and then
         not Is_Null (Deref_List (First_Elem).all) then

         D := Deref_List (First_Elem).all;
         FE_0 := Car (D);

         if Deref (FE_0).Sym_Type = Atom and then
            Deref_Atom (FE_0).Get_Atom = "splice-unquote" then

            -- return a new list containing: a symbol named "concat",
            L.Append (New_Atom_Mal_Type ("concat"));

            -- the second element of first element of ast (ast[0][1]),
            D := Deref_List (Cdr (D)).all;
            L.Append (Car (D));

            -- and the result of calling quasiquote with
            -- the second through last element of ast.
            L.Append (Quasi_Quote_Processing (Cdr (Ast)));

            return Res;

         end if;

      end if;

      -- otherwise: return a new list containing: a symbol named "cons",
      L.Append (New_Atom_Mal_Type ("cons"));

      -- the result of calling quasiquote on first element of ast (ast[0]),
      L.Append (Quasi_Quote_Processing (Car (Ast)));

      -- and result of calling quasiquote with the second through last element of ast.
      L.Append (Quasi_Quote_Processing (Cdr (Ast)));

      return Res;

   end Quasi_Quote_Processing;


   function Catch_Processing
              (Try_Line : Mal_Handle;
               ExStr : Mal_Handle;
               Env : Envs.Env_Handle)
   return Mal_Handle is

      L, CL, CL2, CL3 : List_Mal_Type;
      C : Mal_Handle;
      New_Env : Envs.Env_Handle;

   begin

      L := Deref_List (Try_Line).all;
      C := Car (L);
      -- CL is the list with the catch in.
      CL := Deref_List (C).all;

      CL2 := Deref_List (Cdr (CL)).all;
      New_Env := Envs.New_Env (Env);
      Envs.Set (New_Env, Deref_Atom (Car (CL2)).Get_Atom, ExStr);

      CL3 := Deref_List (Cdr (CL2)).all;
      return Eval (Car (CL3), New_Env);
   end Catch_Processing;

   Mal_Exception_Value : Mal_Handle;

   function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle)
		 return Mal_Handle is
      Param : Mal_Handle;
      Env : Envs.Env_Handle;
      First_Elem : Mal_Handle;
   begin

      Param := AParam;
      Env := AnEnv;

  <<Tail_Call_Opt>>

      if Debug then
         Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
      end if;

      Param := Macro_Expand (Param, Env);

      if Debug then
         Ada.Text_IO.Put_Line ("After expansion " & 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
	    L : Mal_Handle := Param;
	    LMT, Rest_List : List_Mal_Type;
	    First_Elem, Rest_Handle : Mal_Handle;
	 begin

	    LMT := Deref_List (L).all;

	    First_Elem := Car (LMT);

	    Rest_Handle := Cdr (LMT);

	    Rest_List := Deref_List (Rest_Handle).all;

	    case Deref (First_Elem).Sym_Type is

	       when Int | Floating | Bool | Str =>
		  
		  return First_Elem;

	       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 = "defmacro!" then
			return Def_Macro (Rest_List, Env);
		     elsif Atom_P.Get_Atom = "macroexpand" then
			return Macro_Expand (Car (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_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_Atom_Mal_Type ("nil");
			      end if;
			   end if;
			end;

		     elsif Atom_P.Get_Atom = "quote" then
                        return Car (Rest_List);
		     elsif Atom_P.Get_Atom = "quasiquote" then
		        Param := Quasi_Quote_Processing (Car (Rest_List));
		        goto Tail_Call_Opt;
		     elsif Atom_P.Get_Atom = "try*" then
                        declare
                           Res : Mal_Handle;
                        begin
			   return Eval (Car (Rest_List), Env);
                        exception
                           when Mal_Exception =>
                              Res := Catch_Processing
                                       (Cdr (Rest_List),
                                        Mal_Exception_Value,
                                        Env);
                              Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer;
                              return Res;
                           when E : others =>
                              return Catch_Processing
                                       (Cdr (Rest_List),
                                        New_String_Mal_Type
                                          (Ada.Exceptions.Exception_Message (E)),
                                        Env);
                        end;
		     elsif Atom_P.Get_Atom = "throw" then
                         Mal_Exception_Value := Eval (Car (Rest_List), Env);
                         raise Mal_Exception;
		     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
                        return First_Elem;
                     end if;

		  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;
                     -- was:
		     -- 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;

      elsif Deref (Param).Sym_Type = Unitary then
         declare
            UMT : Types.Unitary_Mal_Type;
         begin
            UMT := Deref_Unitary (Param).all;
            case UMT.Get_Func is
               when Quote =>
                  return UMT.Get_Op;
               when QuasiQuote =>
		  Param := Quasi_Quote_Processing (UMT.Get_Op);
                  goto Tail_Call_Opt;
               when Unquote =>
		  Param := UMT.Get_Op;
                  goto Tail_Call_Opt;
               when others => null;
            end case;
         end;
      else

         return Eval_Ast (Param, Env);

      end if;

   end Eval;


end Evaluation;
Commit	Line	Data
9a6f4925	1	with Ada.Text_IO;
18a94a9f	2	with Ada.Exceptions;
9a6f4925 CM	3	with Envs;
	4	with Smart_Pointers;
	5
	6	package body Evaluation is
	7
13ce1681	8	use Types;
9a6f4925	9
13ce1681	10	procedure Add_Defs (Defs : List_Mal_Type; Env : Envs.Env_Handle) is
09c532ba CM	11	D, L : List_Mal_Type;
	12	begin
	13	if Debug then
	14	Ada.Text_IO.Put_Line ("Add_Defs " & To_String (Defs));
	15	end if;
	16	D := Defs;
13ce1681	17	while not Is_Null (D) loop
09c532ba CM	18	L := Deref_List (Cdr (D)).all;
09c532ba CM	19	Envs.Set
13ce1681 CM	20	(Env,
	21	Deref_Atom (Car (D)).Get_Atom,
	22	Eval (Car (L), Env));
09c532ba CM	23	D := Deref_List (Cdr(L)).all;
	24	end loop;
	25	end Add_Defs;
	26
13ce1681	27
0571a45f	28	function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle)
c3244bcf	29	return Mal_Handle is
09c532ba CM	30	Name, Fn_Body, Res : Mal_Handle;
	31	begin
	32	Name := Car (Args);
	33	pragma Assert (Deref (Name).Sym_Type = Atom,
	34	"Def_Fn: expected atom as name");
	35	Fn_Body := Car (Deref_List (Cdr (Args)).all);
13ce1681 CM	36	Res := Eval (Fn_Body, Env);
13ce1681 CM	37	Envs.Set (Envs.Get_Current, Deref_Atom (Name).Get_Atom, Res);
09c532ba CM	38	return Res;
	39	end Def_Fn;
	40
	41
35171f88 CM	42	function Def_Macro (Args : List_Mal_Type; Env : Envs.Env_Handle)
	43	return Mal_Handle is
	44	Name, Fn_Body, Res : Mal_Handle;
	45	Lambda_P : Lambda_Ptr;
	46	begin
	47	Name := Car (Args);
	48	pragma Assert (Deref (Name).Sym_Type = Atom,
	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 (Envs.Get_Current, Deref_Atom (Name).Get_Atom, Res);
	55	return Res;
	56	end Def_Macro;
	57
	58
	59	function Macro_Expand (Ast : Mal_Handle; Env : Envs.Env_Handle)
	60	return Mal_Handle is
	61	Res : Mal_Handle;
4356e17f	62	E : Envs.Env_Handle;
35171f88	63	LMT : List_Mal_Type;
4356e17f	64	LP : Lambda_Ptr;
35171f88 CM	65	begin
	66
	67	Res := Ast;
4356e17f	68	E := Env;
35171f88 CM	69
	70	loop
	71
	72	if Deref (Res).Sym_Type /= List then
4356e17f	73	exit;
35171f88 CM	74	end if;
	75
	76	LMT := Deref_List (Res).all;
	77
4356e17f CM	78	-- Get the macro in the list from the env
	79	-- or return null if not applicable.
	80	LP := Get_Macro (Res, E);
35171f88 CM	81
	82	exit when LP = null or else not LP.Get_Is_Macro;
	83
	84	declare
	85	Fn_List : Mal_Handle := Cdr (LMT);
	86	Params : List_Mal_Type;
35171f88	87	begin
4356e17f CM	88	E := Envs.New_Env (E);
4356e17f CM	89
35171f88 CM	90	Params := Deref_List (LP.Get_Params).all;
	91	if Envs.Bind (E, Params, Deref_List (Fn_List).all) then
	92
	93	Res := Eval (LP.Get_Expr, E);
	94
	95	end if;
	96
	97	end;
	98
	99	end loop;
	100
	101	return Res;
	102
	103	end Macro_Expand;
	104
	105
0571a45f	106	function Let_Processing (Args : List_Mal_Type; Env : Envs.Env_Handle)
c3244bcf	107	return Mal_Handle is
09c532ba	108	Defs, Expr, Res : Mal_Handle;
4356e17f	109	E : Envs.Env_Handle;
09c532ba	110	begin
4356e17f	111	E := Envs.New_Env (Env);
09c532ba	112	Defs := Car (Args);
4356e17f	113	Add_Defs (Deref_List (Defs).all, E);
09c532ba	114	Expr := Car (Deref_List (Cdr (Args)).all);
4356e17f	115	Res := Eval (Expr, E);
09c532ba CM	116	return Res;
	117	end Let_Processing;
	118
	119
0571a45f	120	function Eval_As_Boolean (MH : Mal_Handle) return Boolean is
13ce1681 CM	121	Res : Boolean;
	122	begin
	123	case Deref (MH).Sym_Type is
	124	when Bool =>
	125	Res := Deref_Bool (MH).Get_Bool;
	126	when Atom =>
	127	return not (Deref_Atom (MH).Get_Atom = "nil");
	128	-- when List =>
	129	-- declare
	130	-- L : List_Mal_Type;
	131	-- begin
	132	-- L := Deref_List (MH).all;
	133	-- Res := not Is_Null (L);
	134	-- end;
	135	when others => -- Everything else
	136	Res := True;
	137	end case;
	138	return Res;
	139	end Eval_As_Boolean;
	140
	141
9a6f4925	142	function Eval_Ast
0571a45f	143	(Ast : Mal_Handle; Env : Envs.Env_Handle)
c3244bcf	144	return Mal_Handle is
13ce1681	145
13ce1681 CM	146	function Call_Eval (A : Mal_Handle) return Mal_Handle is
	147	begin
	148	return Eval (A, Env);
	149	end Call_Eval;
	150
9a6f4925	151	begin
09c532ba	152
9a6f4925	153	case Deref (Ast).Sym_Type is
09c532ba	154
066c5345	155	when Atom =>
09c532ba	156
066c5345	157	declare
efaad1ce	158	Sym : Mal_String := Deref_Atom (Ast).Get_Atom;
066c5345	159	begin
13ce1681	160	-- if keyword or nil (which may represent False)...
05a96502 CM	161	if Sym(1) = ':' then
	162	return Ast;
	163	else
13ce1681	164	return Envs.Get (Env, Sym);
05a96502	165	end if;
066c5345 CM	166	exception
066c5345 CM	167	when Envs.Not_Found =>
18a94a9f	168	raise Envs.Not_Found with (" '" & Sym & "' not found ");
066c5345	169	end;
09c532ba	170
9a6f4925	171	when List =>
09c532ba	172
13ce1681	173	return Map (Call_Eval'Unrestricted_Access, Deref_List (Ast).all);
09c532ba	174
efaad1ce CM	175	when Lambda =>
	176
	177	-- Evaluating a lambda in a different Env.
	178	declare
	179	L : Lambda_Ptr;
	180	New_Env : Envs.Env_Handle;
	181	begin
	182	L := Deref_Lambda (Ast);
	183	New_Env := Env;
	184	-- Make the current Lambda's env the outer of the env param.
	185	Envs.Set_Outer (New_Env, L.Get_Env);
	186	-- Make the Lambda's Env.
	187	L.Set_Env (New_Env);
	188	return Ast;
	189	end;
	190
09c532ba CM	191	when others => return Ast;
09c532ba CM	192
9a6f4925	193	end case;
09c532ba	194
9a6f4925 CM	195	end Eval_Ast;
9a6f4925 CM	196
09c532ba	197
0571a45f	198	function Do_Processing (Do_List : List_Mal_Type; Env : Envs.Env_Handle)
c3244bcf	199	return Mal_Handle is
13ce1681 CM	200	D : List_Mal_Type;
	201	Res : Mal_Handle := Smart_Pointers.Null_Smart_Pointer;
	202	begin
	203	if Debug then
	204	Ada.Text_IO.Put_Line ("Do-ing " & To_String (Do_List));
	205	end if;
	206	D := Do_List;
	207	while not Is_Null (D) loop
efaad1ce	208	Res := Eval (Car (D), Env);
13ce1681 CM	209	D := Deref_List (Cdr(D)).all;
	210	end loop;
	211	return Res;
	212	end Do_Processing;
	213
	214
4a33fde1	215	function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is
7afdd78d	216	Res, First_Elem, FE_0 : Mal_Handle;
4a33fde1 CM	217	D, Ast : List_Mal_Type;
	218	L : List_Ptr;
	219	begin
	220
7afdd78d CM	221	if Debug then
	222	Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String);
	223	end if;
	224
38d0c57f CM	225	-- Create a New List for the result...
	226	Res := New_List_Mal_Type (List_List);
	227	L := Deref_List (Res);
	228
7afdd78d CM	229	-- This is the equivalent of Is_Pair
	230	if Deref (Param).Sym_Type /= List or else
	231	Is_Null (Deref_List (Param).all) then
	232
	233	-- return a new list containing: a symbol named "quote" and ast.
38d0c57f CM	234	L.Append (New_Atom_Mal_Type ("quote"));
	235	L.Append (Param);
	236	return Res;
7afdd78d	237
4a33fde1 CM	238	end if;
4a33fde1 CM	239
7afdd78d CM	240	-- Ast is a non-empty list at this point.
7afdd78d CM	241
4a33fde1 CM	242	Ast := Deref_List (Param).all;
4a33fde1 CM	243
7afdd78d	244	First_Elem := Car (Ast);
4a33fde1	245
7afdd78d CM	246	-- if the first element of ast is a symbol named "unquote":
	247	if Deref (First_Elem).Sym_Type = Atom and then
	248	Deref_Atom (First_Elem).Get_Atom = "unquote" then
4a33fde1	249
7afdd78d CM	250	-- return the second element of ast.`
	251	D := Deref_List (Cdr (Ast)).all;
	252	return Car (D);
4a33fde1	253
7afdd78d	254	end if;
4a33fde1	255
7afdd78d CM	256	-- if the first element of first element of `ast` (`ast[0][0]`)
	257	-- is a symbol named "splice-unquote"
	258	if Deref (First_Elem).Sym_Type = List and then
	259	not Is_Null (Deref_List (First_Elem).all) then
4a33fde1	260
7afdd78d CM	261	D := Deref_List (First_Elem).all;
7afdd78d CM	262	FE_0 := Car (D);
4a33fde1	263
7afdd78d CM	264	if Deref (FE_0).Sym_Type = Atom and then
7afdd78d CM	265	Deref_Atom (FE_0).Get_Atom = "splice-unquote" then
4a33fde1	266
7afdd78d CM	267	-- return a new list containing: a symbol named "concat",
7afdd78d CM	268	L.Append (New_Atom_Mal_Type ("concat"));
4a33fde1	269
7afdd78d CM	270	-- the second element of first element of ast (ast[0][1]),
	271	D := Deref_List (Cdr (D)).all;
	272	L.Append (Car (D));
4a33fde1	273
7afdd78d CM	274	-- and the result of calling quasiquote with
	275	-- the second through last element of ast.
	276	L.Append (Quasi_Quote_Processing (Cdr (Ast)));
4a33fde1	277
7afdd78d	278	return Res;
4a33fde1	279
4a33fde1	280	end if;
7afdd78d	281
4a33fde1 CM	282	end if;
	283
	284	-- otherwise: return a new list containing: a symbol named "cons",
	285	L.Append (New_Atom_Mal_Type ("cons"));
	286
	287	-- the result of calling quasiquote on first element of ast (ast[0]),
	288	L.Append (Quasi_Quote_Processing (Car (Ast)));
	289
	290	-- and result of calling quasiquote with the second through last element of ast.
	291	L.Append (Quasi_Quote_Processing (Cdr (Ast)));
	292
	293	return Res;
	294
	295	end Quasi_Quote_Processing;
	296
	297
18a94a9f CM	298	function Catch_Processing
18a94a9f CM	299	(Try_Line : Mal_Handle;
54d1f71e	300	ExStr : Mal_Handle;
18a94a9f CM	301	Env : Envs.Env_Handle)
	302	return Mal_Handle is
	303
	304	L, CL, CL2, CL3 : List_Mal_Type;
	305	C : Mal_Handle;
	306	New_Env : Envs.Env_Handle;
	307
	308	begin
	309
	310	L := Deref_List (Try_Line).all;
	311	C := Car (L);
	312	-- CL is the list with the catch in.
	313	CL := Deref_List (C).all;
	314
	315	CL2 := Deref_List (Cdr (CL)).all;
	316	New_Env := Envs.New_Env (Env);
54d1f71e	317	Envs.Set (New_Env, Deref_Atom (Car (CL2)).Get_Atom, ExStr);
18a94a9f CM	318
	319	CL3 := Deref_List (Cdr (CL2)).all;
	320	return Eval (Car (CL3), New_Env);
	321	end Catch_Processing;
	322
54d1f71e	323	Mal_Exception_Value : Mal_Handle;
18a94a9f	324
a3c4ba44	325	function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle)
c3244bcf	326	return Mal_Handle is
a3c4ba44 CM	327	Param : Mal_Handle;
	328	Env : Envs.Env_Handle;
	329	First_Elem : Mal_Handle;
	330	begin
	331
	332	Param := AParam;
	333	Env := AnEnv;
	334
c3244bcf	335	<<Tail_Call_Opt>>
a3c4ba44 CM	336
	337	if Debug then
	338	Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
	339	end if;
	340
35171f88 CM	341	Param := Macro_Expand (Param, Env);
	342
	343	if Debug then
	344	Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String);
	345	end if;
	346
a3c4ba44	347	if Deref (Param).Sym_Type = List and then
c3244bcf CM	348	Deref_List (Param).all.Get_List_Type = List_List then
	349
	350	declare
	351	L : Mal_Handle := Param;
	352	LMT, Rest_List : List_Mal_Type;
	353	First_Elem, Rest_Handle : Mal_Handle;
	354	begin
	355
	356	LMT := Deref_List (L).all;
	357
	358	First_Elem := Car (LMT);
	359
	360	Rest_Handle := Cdr (LMT);
	361
	362	Rest_List := Deref_List (Rest_Handle).all;
	363
	364	case Deref (First_Elem).Sym_Type is
	365
	366	when Int \| Floating \| Bool \| Str =>
	367
	368	return First_Elem;
	369
	370	when Atom =>
	371
	372	declare
	373	Atom_P : Atom_Ptr;
	374	begin
	375	Atom_P := Deref_Atom (First_Elem);
	376	if Atom_P.Get_Atom = "def!" then
	377	return Def_Fn (Rest_List, Env);
35171f88 CM	378	elsif Atom_P.Get_Atom = "defmacro!" then
	379	return Def_Macro (Rest_List, Env);
	380	elsif Atom_P.Get_Atom = "macroexpand" then
714a6dbe	381	return Macro_Expand (Car (Rest_List), Env);
c3244bcf CM	382	elsif Atom_P.Get_Atom = "let*" then
	383	return Let_Processing (Rest_List, Env);
	384	elsif Atom_P.Get_Atom = "do" then
	385	return Do_Processing (Rest_List, Env);
	386	elsif Atom_P.Get_Atom = "if" then
	387	declare
	388	Args : List_Mal_Type := Rest_List;
	389
	390	Cond, True_Part, False_Part : Mal_Handle;
	391	Cond_Bool : Boolean;
	392	pragma Assert (Length (Args) = 2 or Length (Args) = 3,
	393	"If_Processing: not 2 or 3 parameters");
	394	L : List_Mal_Type;
	395	begin
	396
	397	Cond := Eval (Car (Args), Env);
	398
	399	Cond_Bool := Eval_As_Boolean (Cond);
	400
	401	if Cond_Bool then
	402	L := Deref_List (Cdr (Args)).all;
	403
	404	Param := Car (L);
	405	goto Tail_Call_Opt;
	406	-- was: return Eval (Car (L), Env);
	407	else
	408	if Length (Args) = 3 then
	409	L := Deref_List (Cdr (Args)).all;
	410	L := Deref_List (Cdr (L)).all;
	411
	412	Param := Car (L);
	413	goto Tail_Call_Opt;
	414	-- was: return Eval (Car (L), Env);
	415	else
	416	return New_Atom_Mal_Type ("nil");
	417	end if;
	418	end if;
	419	end;
	420
943b0146 CM	421	elsif Atom_P.Get_Atom = "quote" then
943b0146 CM	422	return Car (Rest_List);
4a33fde1 CM	423	elsif Atom_P.Get_Atom = "quasiquote" then
	424	Param := Quasi_Quote_Processing (Car (Rest_List));
	425	goto Tail_Call_Opt;
18a94a9f CM	426	elsif Atom_P.Get_Atom = "try*" then
18a94a9f CM	427	declare
54d1f71e	428	Res : Mal_Handle;
18a94a9f CM	429	begin
	430	return Eval (Car (Rest_List), Env);
	431	exception
	432	when Mal_Exception =>
54d1f71e	433	Res := Catch_Processing
18a94a9f	434	(Cdr (Rest_List),
54d1f71e	435	Mal_Exception_Value,
18a94a9f	436	Env);
54d1f71e CM	437	Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer;
54d1f71e CM	438	return Res;
18a94a9f CM	439	when E : others =>
	440	return Catch_Processing
	441	(Cdr (Rest_List),
54d1f71e CM	442	New_String_Mal_Type
54d1f71e CM	443	(Ada.Exceptions.Exception_Message (E)),
18a94a9f CM	444	Env);
18a94a9f CM	445	end;
54d1f71e CM	446	elsif Atom_P.Get_Atom = "throw" then
	447	Mal_Exception_Value := Eval (Car (Rest_List), Env);
	448	raise Mal_Exception;
c3244bcf CM	449	else -- not a special form
	450
	451	-- Apply section
	452	declare
	453	Res : Mal_Handle;
	454	begin
	455	-- Eval the atom.
	456	Res := Eval_Ast (L, Env);
	457	Param := Res;
	458	goto Tail_Call_Opt;
	459	-- was: return Eval (Res, Env);
	460	end;
	461
	462	end if;
	463	end;
	464
	465	when Func =>
	466
	467	return Call_Func
	468	(Deref_Func (First_Elem).all,
	469	Rest_Handle,
	470	Env);
	471
	472	when Lambda =>
	473
	474	declare
	475	LP : Lambda_Ptr := Deref_Lambda (First_Elem);
	476	Fn_List : Mal_Handle := Cdr (LMT);
	477	Params : List_Mal_Type;
	478	E : Envs.Env_Handle;
	479	begin
	480	E := Envs.New_Env (LP.Get_Env);
	481	Params := Deref_List (LP.Get_Params).all;
	482	if Envs.Bind (E, Params, Deref_List (Fn_List).all) then
	483
	484	Param := LP.Get_Expr;
	485	Env := E;
	486	goto Tail_Call_Opt;
	487	-- was: return Eval (LP.Get_Expr, E);
	488
a3c4ba44	489	else
c3244bcf	490	return First_Elem;
a3c4ba44	491	end if;
a3c4ba44	492
c3244bcf	493	end;
efaad1ce	494
c3244bcf	495	when List =>
0571a45f	496
c3244bcf CM	497	-- First elem in the list is a list.
	498	-- Eval it and then insert it as first elem in the list and
	499	-- go again.
	500	declare
	501	Evaled_List : Mal_Handle;
	502	E : Envs.Env_Handle;
	503	begin
	504	Evaled_List := Eval (First_Elem, Env);
	505	if Is_Null (Evaled_List) then
	506	return Evaled_List;
	507	elsif Deref (Evaled_List).Sym_Type = Lambda then
	508	E := Deref_Lambda (Evaled_List).Get_Env;
	509	else
	510	E := Env;
	511	end if;
13ce1681	512
c3244bcf CM	513	Param := Prepend (Evaled_List, Rest_List);
	514	Env := E;
	515	goto Tail_Call_Opt;
	516	-- was:
	517	-- Evaled_List := Prepend (Evaled_List, Rest_List);
	518	-- return Eval (Evaled_List, E);
	519	end;
0571a45f	520
c3244bcf	521	when Error => return First_Elem;
0571a45f	522
c3244bcf	523	when Node => return New_Error_Mal_Type ("Evaluating a node");
13ce1681	524
c3244bcf	525	when Unitary => null; -- Not yet impl
efaad1ce	526
c3244bcf	527	end case;
09c532ba	528
c3244bcf	529	end;
09c532ba	530
943b0146 CM	531	elsif Deref (Param).Sym_Type = Unitary then
	532	declare
	533	UMT : Types.Unitary_Mal_Type;
	534	begin
	535	UMT := Deref_Unitary (Param).all;
	536	case UMT.Get_Func is
4a33fde1 CM	537	when Quote =>
	538	return UMT.Get_Op;
	539	when QuasiQuote =>
	540	Param := Quasi_Quote_Processing (UMT.Get_Op);
	541	goto Tail_Call_Opt;
38d0c57f CM	542	when Unquote =>
	543	Param := UMT.Get_Op;
	544	goto Tail_Call_Opt;
943b0146 CM	545	when others => null;
	546	end case;
	547	end;
9a6f4925	548	else
09c532ba	549
13ce1681	550	return Eval_Ast (Param, Env);
09c532ba	551
9a6f4925	552	end if;
09c532ba	553
9a6f4925 CM	554	end Eval;
	555
	556
	557	end Evaluation;