Ada: step 3 complete

ada/Makefile

@@ -1,4 +1,4 @@
-PROGS=step0_repl step1_read_print step2_eval
+PROGS=step0_repl step1_read_print step2_eval step3_env
 
 all:	${PROGS}
 
@@ -14,5 +14,9 @@ step2_eval:	step2_eval.adb types.ad[bs] reader.ad[bs]  printer.ad[bs] \
 		smart_pointers.ad[bs] envs.ad[bs] evaluation.ad[bs]
 	gnatmake -g -P$@
 
+step3_env:	step3_env.adb types.ad[bs] reader.ad[bs]  printer.ad[bs] \
+		smart_pointers.ad[bs] envs.ad[bs] evaluation.ad[bs]
+	gnatmake -g -gnata -P$@
+
 clean:
 	rm -f obj/* ${PROGS}

ada/envs.adb

@@ -1,3 +1,4 @@
+with Ada.Text_IO;
 with Unchecked_Deallocation;
 
 package body Envs is
@@ -11,18 +12,31 @@ package body Envs is
          New_Item  => SP);
    end Set;
 
-
    function Get (Key : String) return Smart_Pointers.Smart_Pointer is
-      use String_Mal_Hash;
-      C : Cursor;
+
+      function Find (Env : Env_Ptr) return Smart_Pointers.Smart_Pointer is
+         use String_Mal_Hash;
+         C : Cursor;
+      begin
+         C := Find (Env.The_Map,
+                    Ada.Strings.Unbounded.To_Unbounded_String (Key));
+
+         if C = No_Element then
+
+            if Env.Prev_Env = null then
+               raise Not_Found;
+            else
+               return Find (Env.Prev_Env);
+            end if;
+
+         else
+            return Element (C);
+         end if;
+
+      end Find;
+
    begin
-      C := Find (Current.The_Map,
-                 Ada.Strings.Unbounded.To_Unbounded_String (Key));
-      if C = No_Element then
-         raise Not_Found;
-      else
-         return Element (C);
-      end if;
+      return Find (Current);
    end Get;
 
 
@@ -44,16 +58,24 @@ package body Envs is
 
 
    procedure New_Env is
+      Old_Env : Env_Ptr;
    begin
+      Old_Env := Current;
       Current := new Environment;
+      Current.Prev_Env := Old_Env;
    end New_Env;
 
 
    procedure Free is new Unchecked_Deallocation (Environment, Env_Ptr);
 
    procedure Delete_Env is
+      TBD : Env_Ptr;
    begin
-      Free (Current);
+      TBD := Current;
+      if Current.Prev_Env /= null then
+         Current := Current.Prev_Env;
+         Free (TBD);
+      end if;
    end Delete_Env;
    
 

ada/envs.ads

@@ -33,12 +33,15 @@ private
       Equivalent_Keys => Ada.Strings.Unbounded."=",
       "="             => Smart_Pointers."=");
 
-   type Environment is record
-      The_Map : String_Mal_Hash.Map;
-   end record;
+   type Environment;
 
    type Env_Ptr is access Environment;
 
+   type Environment is record
+      The_Map : String_Mal_Hash.Map;
+      Prev_Env : Env_Ptr;
+   end record;
+
    Current : Env_Ptr;
 
 end Envs;

ada/evaluation.adb

@@ -12,13 +12,41 @@ package body Evaluation is
    function "/" is new Types.Op ("/", "/");
 
 
+   procedure Add_Defs (Defs : Types.List_Mal_Type) is
+      use Types;
+      Nil : Types.List_Mal_Type := Null_List (Defs.Get_List_Type);
+      D, L : List_Mal_Type;
+   begin
+      if Debug then
+         Ada.Text_IO.Put_Line ("Add_Defs " & To_String (Defs));
+      end if;
+      D := Defs;
+      while D /= Nil loop
+         L := Deref_List (Cdr (D)).all;
+         Envs.Set
+           (Deref_Atom (Car (D)).Get_Atom,
+            Eval (Car (L)));
+         D := Deref_List (Cdr(L)).all;
+      end loop;
+   end Add_Defs;
+
    function Apply (Func : Types.Mal_Handle; Args : Types.List_Mal_Type)
    return Types.Mal_Handle is
       use Types;
    begin
---Ada.Text_IO.Put_Line ("Applying " & To_String (Deref (Func).all) & " to " & Args.To_String);
+
+      if Debug then
+
+         Ada.Text_IO.Put_Line
+           ("Applying " & To_String (Deref (Func).all) &
+            " to " & Args.To_String);
+
+      end if;
+
       case Deref (Func).Sym_Type is
+
          when Sym =>
+
             declare
                Sym_P : Types.Sym_Ptr;
             begin
@@ -31,20 +59,58 @@ package body Evaluation is
                   when others => null;
                end case;
            end;
+
+--         when Atom =>
+
+                
          when Error => return Func;
+
          when others => null;
+
       end case;
       return Smart_Pointers.Null_Smart_Pointer;
    end Apply;
 
 
+   function Def_Fn (Args : Types.List_Mal_Type) return Types.Mal_Handle is
+      use Types;
+      Name, Fn_Body, Res : Mal_Handle;
+   begin
+      Name := Car (Args);
+      pragma Assert (Deref (Name).Sym_Type = Atom,
+                     "Def_Fn: expected atom as name");
+      Fn_Body := Car (Deref_List (Cdr (Args)).all);
+      Res := Eval (Fn_Body);
+      Envs.Set (Deref_Atom (Name).Get_Atom, Res);
+      return Res;
+   end Def_Fn;
+
+
+   function Let_Processing (Args : Types.List_Mal_Type)
+   return Types.Mal_Handle is
+      use Types;
+      Defs, Expr, Res : Mal_Handle;
+   begin
+      Envs.New_Env;
+      Defs := Car (Args);
+      Add_Defs (Deref_List (Defs).all);
+      Expr := Car (Deref_List (Cdr (Args)).all);
+      Res := Eval (Expr);
+      Envs.Delete_Env;
+      return Res;
+   end Let_Processing;
+
+
    function Eval_Ast
      (Ast : Types.Mal_Handle)
    return Types.Mal_Handle is
       use Types;
    begin
+
       case Deref (Ast).Sym_Type is
+
          when Sym =>
+
             declare
               Sym : Mal_String (1..1) := Deref_Sym (Ast).Symbol & "";
             begin
@@ -53,7 +119,9 @@ package body Evaluation is
                when Envs.Not_Found =>
                   return New_Error_Mal_Type ("'" &  Sym & "' not found");
             end;
+
          when Atom =>
+
             declare
               Sym : Mal_String := Deref_Atom (Ast).Get_Atom;
             begin
@@ -67,33 +135,89 @@ package body Evaluation is
                when Envs.Not_Found =>
                   return New_Error_Mal_Type ("'" &  Sym & "' not found");
             end;
+
          when List =>
+
             return Map (Eval'Access, Deref_List (Ast).all);
-         when others =>
-            return Ast;
+
+         when others => return Ast;
+
       end case;
+
    end Eval_Ast;
 
+
+   function List_Processing (L : Types.Mal_Handle)
+   return Types.Mal_Handle is
+      use Types;
+      pragma Assert (Deref (L).Sym_Type = List,
+                     "List_Processing: expected a list");
+      Evaled_List : List_Mal_Type;
+      Func : Mal_Handle;
+      Args : List_Mal_Type;
+   begin
+      Evaled_List := Deref_List (Eval_Ast (L)).all;
+      Func := Car (Evaled_List);
+      Args := Deref_List (Cdr (Evaled_List)).all;
+      return Apply (Func, Args);
+   end List_Processing;
+
+
+   function Eval_List (L : Types.Mal_Handle) return Types.Mal_Handle is
+      use Types;
+      pragma Assert (Deref (L).Sym_Type = List,
+                     "Eval_List: expected a List");
+      LMT : List_Mal_Type;
+      First_Elem : Mal_Handle;
+   begin
+
+      LMT := Deref_List (L).all;
+
+      First_Elem := Car (LMT);
+
+      if Deref (First_Elem).Sym_Type = Atom then
+
+         declare
+            Atom_P : Atom_Ptr;
+         begin
+            Atom_P := Deref_Atom (First_Elem);
+            if Atom_P.Get_Atom = "def!" then
+               return Def_Fn (Deref_List (Cdr (LMT)).all);
+            elsif Atom_P.Get_Atom = "let*" then
+               return Let_Processing (Deref_List (Cdr (LMT)).all);
+            else -- not a special form
+               return List_Processing (L);
+            end if;
+         end;
+
+      else -- First elem in list is not an atom
+         return List_Processing (L);
+      end if;
+
+   end Eval_List;
+
+
    function Eval (Param : Types.Mal_Handle)
    return Types.Mal_Handle is
       use Types;
+      First_Elem : Mal_Handle;
    begin
---Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
+
+      if Debug then
+         Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
+      end if;
+
       if Deref (Param).Sym_Type = List and then
          Deref_List (Param).all.Get_List_Type = List_List then
-         declare
-            Evaled_List : Types.List_Mal_Type;
-            Func : Types.Mal_Handle;
-            Args : Types.List_Mal_Type;
-         begin
-            Evaled_List := Deref_List (Eval_Ast (Param)).all;
-            Func := Types.Car (Evaled_List);
-            Args := Types.Cdr (Evaled_List);
-            return Apply (Func, Args);
-         end;
+
+         return Eval_List (Param);
+
       else
+
          return Eval_Ast (Param);
+
       end if;
+
    end Eval;
 
 

ada/evaluation.ads

@@ -5,4 +5,8 @@ package Evaluation is
    function Eval (Param : Types.Mal_Handle)
    return Types.Mal_Handle;
 
+   Evaluation_Error : exception;
+
+   Debug : Boolean := False;
+
 end Evaluation;

ada/reader.adb

@@ -70,7 +70,7 @@ package body Reader is
    Body_Chars : Ada.Strings.Maps.Character_Set :=
      Ada.Strings.Maps."or"
        (Ada.Strings.Maps.Constants.Alphanumeric_Set,
-        Ada.Strings.Maps.To_Set ("-!"));
+        Ada.Strings.Maps.To_Set ("-!*"));
 
    Atom_Recognizer  : constant Tokenizer.Recognizable_Token :=
      Tokenizer.Get

ada/step3_env.adb

@@ -0,0 +1,69 @@
+with Ada.Command_Line;
+with Ada.Text_IO;
+with Ada.IO_Exceptions;
+with Envs;
+with Evaluation;
+with Printer;
+with Reader;
+with Types;
+
+procedure Step3_Env is
+
+   function Read (Param : String) return Types.Mal_Handle is
+   begin
+      return Reader.Read_Str (Param);
+   end Read;
+
+
+   -- Eval can't be here because there are function pointers that point
+   -- at it.  Thus it must be at library level.  See evaluation.ads
+
+
+   function Print (Param : Types.Mal_Handle) return String is
+   begin
+      return Printer.Pr_Str (Param);
+   end Print;
+
+   function Rep (Param : String) return String is
+     AST, Evaluated_AST : Types.Mal_Handle;
+   begin
+
+     AST := Read (Param);
+
+     if Types.Is_Null (AST) then
+        return "";
+     else
+        Evaluated_AST := Evaluation.Eval (AST);
+        return Print (Evaluated_AST);
+     end if;
+
+   end Rep; 
+
+   S : String (1..Reader.Max_Line_Len);
+   Last : Natural;
+
+begin
+
+   if Ada.Command_Line.Argument_Count > 0 then
+     if Ada.Command_Line.Argument (1) = "-d" then
+        Evaluation.Debug := True;
+     end if;
+   end if;
+
+   Envs.New_Env;
+
+   Envs.Set ("+", Types.New_Sym_Mal_Type ('+'));
+   Envs.Set ("-", Types.New_Sym_Mal_Type ('-'));
+   Envs.Set ("*", Types.New_Sym_Mal_Type ('*'));
+   Envs.Set ("/", Types.New_Sym_Mal_Type ('/'));
+
+   loop
+      Ada.Text_IO.Put ("user> ");
+      Ada.Text_IO.Get_Line (S, Last);
+      Ada.Text_IO.Put_Line (Rep (S (1..Last)));
+   end loop;
+
+exception
+   when Ada.IO_Exceptions.End_Error => null;
+   -- i.e. exit without textual output
+end Step3_Env;

ada/step3_env.gpr

@@ -0,0 +1,9 @@
+with "opentoken";
+
+project Step3_Env is
+
+   for Object_Dir use "obj";
+   for Exec_Dir use ".";
+   for Main use ("step3_env.adb");
+
+end Step3_Env;

ada/types.adb

@@ -178,7 +178,7 @@ package body Types is
 
    function Deref_Atom (S : Mal_Handle) return Atom_Ptr is
    begin
-      return Atom_Ptr (Smart_Pointers.Deref (S));
+      return Atom_Ptr (Deref (S));
    end Deref_Atom;
 
    overriding function To_Str (T : Atom_Mal_Type) return Mal_String is
@@ -329,6 +329,26 @@ package body Types is
       end if;
    end Append;
 
+   function Node_Length (L : Mal_Handle) return Natural is
+      Right  : Mal_Handle;
+   begin
+      if Is_Null (L) then
+         return 0;
+      else
+         Right := Deref_Node (L).Right;
+         if Is_Null (Right) then
+            -- Its a node; there must be something in the Left, right? ;)
+            return 1;
+         elsif Deref (Right).Sym_Type = Node then
+            -- Right is a node so recurse but +1 for the Left just passed.
+            return Node_Length (Right) + 1;
+         else
+            -- Right is not null but not node.
+            return 2;
+         end if;
+      end if;
+   end Node_Length;
+
    -- Get the first item in the list:
    function Car (L : List_Mal_Type) return Mal_Handle is
    begin
@@ -341,10 +361,11 @@ package body Types is
    
    
    -- Get the rest of the list (second item onwards)
-   function Cdr (L : List_Mal_Type) return List_Mal_Type is
+   function Cdr (L : List_Mal_Type) return Mal_Handle is
    begin
-      if Is_Null (L.The_List) then
-         return L;
+      if Is_Null (L.The_List) or else
+         Is_Null (Deref_Node (L.The_List).Right) then
+         return New_List_Mal_Type (L.List_Type);
       end if;
       declare
          Node_P : Node_Ptr;
@@ -353,10 +374,22 @@ package body Types is
          -- Clojure lists are constants?
          -- If not, need to copy P.Right to a new list...
          -- Or maybe we copy on write?
-         return Deref_List (New_List_Mal_Type (L.List_Type, Node_P.Right)).all;
+         if Deref (Node_P.Right).Sym_Type = Node then
+            return New_List_Mal_Type (L.List_Type, Node_P.Right);
+         else
+            -- Right is not a Node! We'd better make one.
+            return New_List_Mal_Type
+                     (L.List_Type,
+                      New_Node_Mal_Type (Left => Node_P.Right));
+         end if;
       end;
    end Cdr;
 
+   function Length (L : List_Mal_Type) return Natural is
+   begin
+      return Node_Length (L.The_List);
+   end Length;
+
    function Null_List (L : List_Types) return List_Mal_Type is
    begin
       return (Mal_Type with List_Type => L,

ada/types.ads

@@ -156,11 +156,13 @@ package Types is
 
    procedure Append (To_List : in out List_Mal_Type; Op : Mal_Handle);
 
+   function Length (L : List_Mal_Type) return Natural;
+
    -- Get the first item in the list:
    function Car (L : List_Mal_Type) return Mal_Handle;
 
    -- Get the rest of the list (second item onwards)
-   function Cdr (L : List_Mal_Type) return List_Mal_Type;
+   function Cdr (L : List_Mal_Type) return Mal_Handle;
 
    type Func_Access is access
      function (Elem : Mal_Handle)