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

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

procedure StepA_Mal is

   use Types;

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

   Debug : Boolean := False;


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


   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 := Nth (Args, 1);
      Res := Eval (Fn_Body, Env);
      Envs.Set (Env, Deref_Sym (Name).Get_Sym, 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 = Sym,
                     "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 (Env, Deref_Sym (Name).Get_Sym, 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 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 Nil =>
            return False;
--         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 others => return Ast;

      end case;

   end Eval_Ast;


   function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is
      Res, First_Elem, FE_0 : Mal_Handle;
      L : List_Ptr;
      D_Ptr, Ast_P : List_Class_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_Class (Param).all) then

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

      end if;

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

      Ast_P := Deref_List_Class (Param);

      First_Elem := Car (Ast_P.all);

      -- if the first element of ast is a symbol named "unquote":
      if Deref (First_Elem).Sym_Type = Sym and then
         Deref_Sym (First_Elem).Get_Sym = "unquote" then

         -- return the second element of ast.`
         D_Ptr := Deref_List_Class (Cdr (Ast_P.all));
         return Car (D_Ptr.all);

      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_Class (First_Elem).all) then

         D_Ptr := Deref_List_Class (First_Elem);
         FE_0 := Car (D_Ptr.all);

         if Deref (FE_0).Sym_Type = Sym and then
            Deref_Sym (FE_0).Get_Sym = "splice-unquote" then

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

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

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

            return Res;

         end if;

      end if;

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

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

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

      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_Sym (Car (CL2)).Get_Sym, ExStr);

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


   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;

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

         Param_List := Deref_List (Param).all;

         -- Deal with empty list..
         if Param_List.Length = 0 then
	    return Param;
         end if;

         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 = "defmacro!" then
            return Def_Macro (Rest_List, Env);
         elsif Deref (First_Param).Sym_Type = Sym and then
               Deref_Sym (First_Param).Get_Sym = "macroexpand" then
            return Macro_Expand (Car (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_Nil_Mal_Type;
	          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);

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

            return Car (Rest_List);

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

            Param := Quasi_Quote_Processing (Car (Rest_List));
            goto Tail_Call_Opt;

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

            declare
               Res : Mal_Handle;
            begin
               return Eval (Car (Rest_List), Env);
            exception
               when Mal_Exception =>
                  Res := Catch_Processing
                           (Cdr (Rest_List),
                            Types.Mal_Exception_Value,
                            Env);
                  Types.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;

         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);
               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 -- not a List_List

         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; Env : Envs.Env_Handle) 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, Env);
        return Print (Evaluated_AST);
     end if;

   end Rep;


   Repl_Env : Envs.Env_Handle;


   -- These two ops use Repl_Env directly.


   procedure RE (Str : Mal_String) is
      Discarded : Mal_Handle;
   begin
      Discarded := Eval (Read (Str), Repl_Env);
   end RE;


   function Do_Eval (Rest_Handle : Mal_Handle)
   return Types.Mal_Handle is
      First_Param : Mal_Handle;
      Rest_List : Types.List_Mal_Type;
   begin
      Rest_List := Deref_List (Rest_Handle).all;
      First_Param := Car (Rest_List);
      return Eval_Callback.Eval.all (First_Param, Repl_Env);
   end Do_Eval;


   Cmd_Args, File_Param : Natural;
   Command_Args : Types.Mal_Handle;
   Command_List : Types.List_Ptr;
   File_Processed : Boolean := False;


begin


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

   Repl_Env := Envs.New_Env;

   -- Core init also creates the first environment.
   -- This is needed for the def!'s below.
   Core.Init (Repl_Env);

   -- Register the eval command.  This needs to be done here rather than Core.Init
   -- as it requires direct access to Repl_Env.
   Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access));

   RE ("(def! not (fn* (a) (if a false true)))");
   RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) "")"")))))");
   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)))))))");
   RE ("(def! *gensym-counter* (atom 0))");
   RE ("(def! gensym (fn* [] (symbol (str ""G__"" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))");
   RE ("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))");

   Cmd_Args := 0;
   Command_Args := Types.New_List_Mal_Type (Types.List_List);
   Command_List := Types.Deref_List (Command_Args);

   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;
     elsif not File_Processed then
        File_Param := Cmd_Args;
        File_Processed := True;
     else
        Command_List.Append
          (Types.New_String_Mal_Type (Ada.Command_Line.Argument (Cmd_Args)));
     end if;

   end loop;

   Envs.Set (Repl_Env, "*ARGV*", Command_Args);

   if File_Processed then
      RE ("(load-file """ & Ada.Command_Line.Argument (File_Param) & """)");
   else
      RE("(println (str ""Mal ["" *host-language* ""]""))");
      loop
         begin
            Ada.Text_IO.Put ("user> ");
            exit when Ada.Text_IO.End_Of_File;
            Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env));
         exception
            when E : others =>
               Ada.Text_IO.Put_Line
                 (Ada.Text_IO.Standard_Error,
                  Ada.Exceptions.Exception_Information (E));
         end;
      end loop;
   end if;
end StepA_Mal;
Commit	Line	Data
5b77d5f7 CM	1	with Ada.Command_Line;
	2	with Ada.Exceptions;
	3	with Ada.Text_IO;
5b77d5f7 CM	4	with Core;
5b77d5f7 CM	5	with Envs;
18e21187	6	with Eval_Callback;
5b77d5f7 CM	7	with Printer;
5b77d5f7 CM	8	with Reader;
18e21187	9	with Smart_Pointers;
5b77d5f7 CM	10	with Types;
	11
	12	procedure StepA_Mal is
	13
18e21187 CM	14	use Types;
18e21187 CM	15
18e21187 CM	16	function Eval (AParam : Types.Mal_Handle; AnEnv : Envs.Env_Handle)
	17	return Types.Mal_Handle;
	18
	19	Debug : Boolean := False;
	20
	21
b5bad5ea CM	22	function Read (Param : String) return Types.Mal_Handle is
	23	begin
	24	return Reader.Read_Str (Param);
	25	end Read;
	26
18e21187 CM	27
	28	function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle)
	29	return Mal_Handle is
	30	Name, Fn_Body, Res : Mal_Handle;
	31	begin
	32	Name := Car (Args);
	33	pragma Assert (Deref (Name).Sym_Type = Sym,
	34	"Def_Fn: expected atom as name");
b5bad5ea	35	Fn_Body := Nth (Args, 1);
18e21187	36	Res := Eval (Fn_Body, Env);
b5bad5ea	37	Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res);
18e21187 CM	38	return Res;
	39	end Def_Fn;
	40
	41
	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 = 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);
b5bad5ea	54	Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res);
18e21187 CM	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;
	62	E : Envs.Env_Handle;
	63	LMT : List_Mal_Type;
	64	LP : Lambda_Ptr;
	65	begin
	66
	67	Res := Ast;
	68	E := Env;
	69
	70	loop
	71
	72	if Deref (Res).Sym_Type /= List then
	73	exit;
	74	end if;
	75
	76	LMT := Deref_List (Res).all;
	77
	78	-- Get the macro in the list from the env
	79	-- or return null if not applicable.
	80	LP := Get_Macro (Res, E);
	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;
	87	begin
	88	E := Envs.New_Env (E);
	89
	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
	106	function Eval_As_Boolean (MH : Mal_Handle) return Boolean is
	107	Res : Boolean;
	108	begin
	109	case Deref (MH).Sym_Type is
	110	when Bool =>
	111	Res := Deref_Bool (MH).Get_Bool;
8083b525 CM	112	when Nil =>
8083b525 CM	113	return False;
18e21187 CM	114	-- when List =>
	115	-- declare
	116	-- L : List_Mal_Type;
	117	-- begin
	118	-- L := Deref_List (MH).all;
	119	-- Res := not Is_Null (L);
	120	-- end;
	121	when others => -- Everything else
	122	Res := True;
	123	end case;
	124	return Res;
	125	end Eval_As_Boolean;
	126
	127
	128	function Eval_Ast
	129	(Ast : Mal_Handle; Env : Envs.Env_Handle)
	130	return Mal_Handle is
	131
	132	function Call_Eval (A : Mal_Handle) return Mal_Handle is
	133	begin
	134	return Eval (A, Env);
	135	end Call_Eval;
	136
	137	begin
	138
	139	case Deref (Ast).Sym_Type is
	140
	141	when Sym =>
	142
	143	declare
	144	Sym : Mal_String := Deref_Sym (Ast).Get_Sym;
	145	begin
	146	-- if keyword, return it. Otherwise look it up in the environment.
	147	if Sym(1) = ':' then
	148	return Ast;
	149	else
	150	return Envs.Get (Env, Sym);
	151	end if;
	152	exception
	153	when Envs.Not_Found =>
564a4525	154	raise Envs.Not_Found with ("'" & Sym & "' not found");
18e21187 CM	155	end;
	156
	157	when List =>
	158
	159	return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
	160
18e21187 CM	161	when others => return Ast;
	162
	163	end case;
	164
	165	end Eval_Ast;
	166
	167
18e21187 CM	168	function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is
	169	Res, First_Elem, FE_0 : Mal_Handle;
	170	L : List_Ptr;
	171	D_Ptr, Ast_P : List_Class_Ptr;
	172	begin
	173
	174	if Debug then
	175	Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String);
	176	end if;
	177
	178	-- Create a New List for the result...
	179	Res := New_List_Mal_Type (List_List);
	180	L := Deref_List (Res);
	181
	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
	185
	186	-- return a new list containing: a symbol named "quote" and ast.
	187	L.Append (New_Symbol_Mal_Type ("quote"));
	188	L.Append (Param);
	189	return Res;
	190
	191	end if;
	192
	193	-- Ast is a non-empty list at this point.
	194
	195	Ast_P := Deref_List_Class (Param);
	196
	197	First_Elem := Car (Ast_P.all);
	198
	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
	202
	203	-- return the second element of ast.`
	204	D_Ptr := Deref_List_Class (Cdr (Ast_P.all));
	205	return Car (D_Ptr.all);
	206
	207	end if;
	208
	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
	213
	214	D_Ptr := Deref_List_Class (First_Elem);
	215	FE_0 := Car (D_Ptr.all);
	216
	217	if Deref (FE_0).Sym_Type = Sym and then
	218	Deref_Sym (FE_0).Get_Sym = "splice-unquote" then
	219
	220	-- return a new list containing: a symbol named "concat",
	221	L.Append (New_Symbol_Mal_Type ("concat"));
	222
	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));
	226
	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)));
	230
	231	return Res;
232
233	end if;
234
235	end if;
236
237	-- otherwise: return a new list containing: a symbol named "cons",
238	L.Append (New_Symbol_Mal_Type ("cons"));
239
240	-- the result of calling quasiquote on first element of ast (ast[0]),
241	L.Append (Quasi_Quote_Processing (Car (Ast_P.all)));
242
243	-- and result of calling quasiquote with the second through last element of ast.
244	L.Append (Quasi_Quote_Processing (Cdr (Ast_P.all)));
245
246	return Res;
247
248	end Quasi_Quote_Processing;
249
250
251	function Catch_Processing
252	(Try_Line : Mal_Handle;
253	ExStr : Mal_Handle;
254	Env : Envs.Env_Handle)
255	return Mal_Handle is
256
257	L, CL, CL2, CL3 : List_Mal_Type;
258	C : Mal_Handle;
259	New_Env : Envs.Env_Handle;
260
261	begin
262
263	L := Deref_List (Try_Line).all;
264	C := Car (L);
265	-- CL is the list with the catch in.
266	CL := Deref_List (C).all;
267
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);
271
272	CL3 := Deref_List (Cdr (CL2)).all;
273	return Eval (Car (CL3), New_Env);
274	end Catch_Processing;
275
276
277	function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle)
278	return Mal_Handle is
279	Param : Mal_Handle;
280	Env : Envs.Env_Handle;
281	First_Param, Rest_Params : Mal_Handle;
282	Rest_List, Param_List : List_Mal_Type;
283	begin
284
285	Param := AParam;
286	Env := AnEnv;
287
b5bad5ea	288	<<Tail_Call_Opt>>
18e21187 CM	289
	290	if Debug then
	291	Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
	292	end if;
	293
	294	Param := Macro_Expand (Param, Env);
	295
	296	if Debug then
	297	Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String);
	298	end if;
	299
	300	if Deref (Param).Sym_Type = List and then
	301	Deref_List (Param).Get_List_Type = List_List then
	302
	303	Param_List := Deref_List (Param).all;
74a87bd5 CM	304
	305	-- Deal with empty list..
	306	if Param_List.Length = 0 then
	307	return Param;
	308	end if;
	309
18e21187 CM	310	First_Param := Car (Param_List);
	311	Rest_Params := Cdr (Param_List);
	312	Rest_List := Deref_List (Rest_Params).all;
	313
	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
	325	declare
	326	Defs, Expr, Res : Mal_Handle;
	327	E : Envs.Env_Handle;
	328	begin
	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);
	333	Param := Expr;
	334	Env := E;
	335	goto Tail_Call_Opt;
	336	-- was:
	337	-- Res := Eval (Expr, E);
	338	-- return Res;
	339	end;
	340	elsif Deref (First_Param).Sym_Type = Sym and then
	341	Deref_Sym (First_Param).Get_Sym = "do" then
	342	declare
	343	D : List_Mal_Type;
	344	E : Mal_Handle;
	345	begin
	346
	347	if Debug then
	348	Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List));
	349	end if;
	350
	351	if Is_Null (Rest_List) then
	352	return Rest_Params;
	353	end if;
	354
	355	-- Loop processes Evals all but last entry
	356	D := Rest_List;
	357	loop
	358	E := Car (D);
	359	D := Deref_List (Cdr (D)).all;
	360	exit when Is_Null (D);
	361	E := Eval (E, Env);
	362	end loop;
	363
	364	Param := E;
	365	goto Tail_Call_Opt;
	366
	367	end;
	368	elsif Deref (First_Param).Sym_Type = Sym and then
	369	Deref_Sym (First_Param).Get_Sym = "if" then
	370	declare
	371	Args : List_Mal_Type := Rest_List;
	372
	373	Cond, True_Part, False_Part : Mal_Handle;
374	Cond_Bool : Boolean;
375	pragma Assert (Length (Args) = 2 or Length (Args) = 3,
376	"If_Processing: not 2 or 3 parameters");
377	L : List_Mal_Type;
378	begin
379
380	Cond := Eval (Car (Args), Env);
381
382	Cond_Bool := Eval_As_Boolean (Cond);
383
384	if Cond_Bool then
385	L := Deref_List (Cdr (Args)).all;
386
387	Param := Car (L);
388	goto Tail_Call_Opt;
389	-- was: return Eval (Car (L), Env);
390	else
391	if Length (Args) = 3 then
392	L := Deref_List (Cdr (Args)).all;
393	L := Deref_List (Cdr (L)).all;
394
395	Param := Car (L);
396	goto Tail_Call_Opt;
397	-- was: return Eval (Car (L), Env);
398	else
8083b525	399	return New_Nil_Mal_Type;
18e21187 CM	400	end if;
	401	end if;
	402	end;
	403
	404	elsif Deref (First_Param).Sym_Type = Sym and then
	405	Deref_Sym (First_Param).Get_Sym = "fn*" then
	406
	407	return New_Lambda_Mal_Type
	408	(Params => Car (Rest_List),
	409	Expr => Nth (Rest_List, 1),
	410	Env => Env);
	411
	412	elsif Deref (First_Param).Sym_Type = Sym and then
	413	Deref_Sym (First_Param).Get_Sym = "quote" then
	414
	415	return Car (Rest_List);
	416
	417	elsif Deref (First_Param).Sym_Type = Sym and then
	418	Deref_Sym (First_Param).Get_Sym = "quasiquote" then
	419
	420	Param := Quasi_Quote_Processing (Car (Rest_List));
	421	goto Tail_Call_Opt;
	422
	423	elsif Deref (First_Param).Sym_Type = Sym and then
	424	Deref_Sym (First_Param).Get_Sym = "try*" then
	425
	426	declare
	427	Res : Mal_Handle;
	428	begin
	429	return Eval (Car (Rest_List), Env);
	430	exception
	431	when Mal_Exception =>
	432	Res := Catch_Processing
	433	(Cdr (Rest_List),
	434	Types.Mal_Exception_Value,
	435	Env);
	436	Types.Mal_Exception_Value :=
	437	Smart_Pointers.Null_Smart_Pointer;
	438	return Res;
	439	when E : others =>
	440	return Catch_Processing
	441	(Cdr (Rest_List),
	442	New_String_Mal_Type
	443	(Ada.Exceptions.Exception_Message (E)),
	444	Env);
	445	end;
	446
	447	else
	448
	449	-- The APPLY section.
	450	declare
	451	Evaled_H : Mal_Handle;
	452	begin
	453	Evaled_H := Eval_Ast (Param, Env);
	454
	455	Param_List := Deref_List (Evaled_H).all;
	456
	457	First_Param := Car (Param_List);
	458	Rest_Params := Cdr (Param_List);
	459	Rest_List := Deref_List (Rest_Params).all;
	460
	461	if Deref (First_Param).Sym_Type = Func then
1c28e560	462	return Call_Func (Deref_Func (First_Param).all, Rest_Params);
18e21187 CM	463	elsif Deref (First_Param).Sym_Type = Lambda then
	464	declare
	465
	466	L : Lambda_Mal_Type;
	467	E : Envs.Env_Handle;
	468	Param_Names : List_Mal_Type;
	469	Res : Mal_Handle;
	470
	471	begin
	472
	473	L := Deref_Lambda (First_Param).all;
	474	E := Envs.New_Env (L.Get_Env);
	475
	476	Param_Names := Deref_List (L.Get_Params).all;
	477
	478	if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then
	479
	480	Param := L.Get_Expr;
	481	Env := E;
	482	goto Tail_Call_Opt;
	483	-- was: return Eval (L.Get_Expr, E);
	484
	485	else
	486
	487	raise Mal_Exception with "Bind failed in Apply";
	488
	489	end if;
	490
	491	end;
	492
	493	else -- neither a Lambda or a Func
	494	raise Mal_Exception;
	495	end if;
	496
	497	end;
	498
	499	end if;
	500
	501	else -- not a List_List
	502
	503	return Eval_Ast (Param, Env);
	504
	505	end if;
	506
	507	end Eval;
5b77d5f7 CM	508
	509
	510	function Print (Param : Types.Mal_Handle) return String is
	511	begin
	512	return Printer.Pr_Str (Param);
	513	end Print;
	514
18e21187	515
b5bad5ea	516	function Rep (Param : String; Env : Envs.Env_Handle) return String is
5b77d5f7 CM	517	AST, Evaluated_AST : Types.Mal_Handle;
	518	begin
	519
	520	AST := Read (Param);
	521
	522	if Types.Is_Null (AST) then
	523	return "";
	524	else
b5bad5ea	525	Evaluated_AST := Eval (AST, Env);
5b77d5f7 CM	526	return Print (Evaluated_AST);
	527	end if;
	528
311cbfc0	529	end Rep;
5b77d5f7	530
18e21187	531
b5bad5ea CM	532	Repl_Env : Envs.Env_Handle;
	533
	534
	535	-- These two ops use Repl_Env directly.
	536
	537
	538	procedure RE (Str : Mal_String) is
	539	Discarded : Mal_Handle;
	540	begin
	541	Discarded := Eval (Read (Str), Repl_Env);
	542	end RE;
	543
	544
1c28e560	545	function Do_Eval (Rest_Handle : Mal_Handle)
b5bad5ea CM	546	return Types.Mal_Handle is
	547	First_Param : Mal_Handle;
	548	Rest_List : Types.List_Mal_Type;
	549	begin
	550	Rest_List := Deref_List (Rest_Handle).all;
	551	First_Param := Car (Rest_List);
	552	return Eval_Callback.Eval.all (First_Param, Repl_Env);
	553	end Do_Eval;
	554
	555
f049dc3a	556	Cmd_Args, File_Param : Natural;
5b77d5f7 CM	557	Command_Args : Types.Mal_Handle;
	558	Command_List : Types.List_Ptr;
	559	File_Processed : Boolean := False;
	560
18e21187	561
5b77d5f7 CM	562	begin
5b77d5f7 CM	563
18e21187 CM	564
	565	-- Save a function pointer back to the Eval function.
	566	-- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK
	567	-- as we know Eval will be in scope for the lifetime of the program.
	568	Eval_Callback.Eval := Eval'Unrestricted_Access;
	569
b5bad5ea CM	570	Repl_Env := Envs.New_Env;
b5bad5ea CM	571
5b77d5f7 CM	572	-- Core init also creates the first environment.
5b77d5f7 CM	573	-- This is needed for the def!'s below.
b5bad5ea CM	574	Core.Init (Repl_Env);
	575
	576	-- Register the eval command. This needs to be done here rather than Core.Init
	577	-- as it requires direct access to Repl_Env.
	578	Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access));
	579
	580	RE ("(def! not (fn* (a) (if a false true)))");
	581	RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) "")"")))))");
	582	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)))))))");
	583	RE ("(def! gensym-counter (atom 0))");
	584	RE ("(def! gensym (fn* [] (symbol (str ""G__"" (swap! gensym-counter (fn* [x] (+ 1 x)))))))");
	585	RE ("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))");
5b77d5f7 CM	586
	587	Cmd_Args := 0;
	588	Command_Args := Types.New_List_Mal_Type (Types.List_List);
	589	Command_List := Types.Deref_List (Command_Args);
	590
	591	while Ada.Command_Line.Argument_Count > Cmd_Args loop
	592
	593	Cmd_Args := Cmd_Args + 1;
	594	if Ada.Command_Line.Argument (Cmd_Args) = "-d" then
18e21187	595	Debug := True;
5b77d5f7 CM	596	elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then
5b77d5f7 CM	597	Envs.Debug := True;
f049dc3a CM	598	elsif not File_Processed then
	599	File_Param := Cmd_Args;
	600	File_Processed := True;
5b77d5f7	601	else
f049dc3a	602	Command_List.Append
9c38eb6d	603	(Types.New_String_Mal_Type (Ada.Command_Line.Argument (Cmd_Args)));
5b77d5f7 CM	604	end if;
	605
	606	end loop;
	607
b5bad5ea	608	Envs.Set (Repl_Env, "ARGV", Command_Args);
5b77d5f7	609
f049dc3a	610	if File_Processed then
b5bad5ea	611	RE ("(load-file """ & Ada.Command_Line.Argument (File_Param) & """)");
453a89a0	612	else
6faafa00	613	RE("(println (str ""Mal ["" host-language ""]""))");
453a89a0 CM	614	loop
	615	begin
	616	Ada.Text_IO.Put ("user> ");
311cbfc0 CM	617	exit when Ada.Text_IO.End_Of_File;
311cbfc0 CM	618	Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env));
453a89a0	619	exception
453a89a0 CM	620	when E : others =>
	621	Ada.Text_IO.Put_Line
	622	(Ada.Text_IO.Standard_Error,
	623	Ada.Exceptions.Exception_Information (E));
	624	end;
	625	end loop;
f049dc3a	626	end if;
5b77d5f7	627	end StepA_Mal;