[jackhill/mal.git] / ada / stepa_mal.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 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;
         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;


   S : String (1..Reader.Max_Line_Len);
   Last : Natural;
   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_Symbol_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
      loop
         begin
            Ada.Text_IO.Put ("user> ");
            Ada.Text_IO.Get_Line (S, Last);
            Ada.Text_IO.Put_Line (Rep (S (1..Last), Repl_Env));
         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;
   end if;

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