Change quasiquote algorithm

[jackhill/mal.git] / impls / ada / envs.adb

with Ada.Text_IO;
with Types;
with Unchecked_Deallocation;

package body Envs is


   function Is_Null (E : Env_Handle) return Boolean is
      use Smart_Pointers;
   begin
     return E = Null_Env_Handle;
   end Is_Null;


   function New_Env (Outer : Env_Handle := Null_Env_Handle) return Env_Handle is
      use Smart_Pointers;
      Level : Natural;
   begin
      if Is_Null (Outer) then
         Level := 0;
      else
         Level := Deref (Outer).Level + 1;
      end if;
      if Debug then
         Ada.Text_IO.Put_Line
           ("Envs: Creating at level " & Natural'Image (Level));
      end if;
      return Env_Handle (Smart_Pointers.New_Ptr (new Env'
               (Base_Class with The_Map => String_Mal_Hash.Empty_Map,
                Outer_Env => Outer,
                Level => Level)));
   end New_Env;


   procedure Set
     (E : Env_Handle;
      Key : String;
      Elem : Smart_Pointers.Smart_Pointer) is
   begin
      if Debug then
         Ada.Text_IO.Put_Line
           ("Envs: Setting " & Key &
            " to " & Types.Deref (Elem).To_String &
            " at level " & Natural'Image (Deref (E).Level));
      end if;
      String_Mal_Hash.Include
        (Container => Deref (E).The_Map,
         Key       => Ada.Strings.Unbounded.To_Unbounded_String (Key),
         New_Item  => Elem);
   end Set;


   function Get (E : Env_Handle; Key: String)
   return Smart_Pointers.Smart_Pointer is

      use String_Mal_Hash;
      C : Cursor;

   begin

      if Debug then
         Ada.Text_IO.Put_Line
           ("Envs: Finding " & Key &
            " at level " & Natural'Image (Deref (E).Level));
      end if;

      C := Find (Deref (E).The_Map,
                 Ada.Strings.Unbounded.To_Unbounded_String (Key));

      if C = No_Element then

         if Is_Null (Deref (E).Outer_Env) then
            raise Not_Found;
         else
            return Get (Deref (E).Outer_Env, Key);
         end if;

      else
         return Element (C);
      end if;

   end Get;


   procedure Set_Outer
     (E : Env_Handle; Outer_Env : Env_Handle) is
   begin
      -- Attempt to avoid making loops.
      if Deref (E).Level /= 0 then
         Deref (E).Outer_Env := Outer_Env;
      end if;
   end Set_Outer;


   function To_String (E : Env_Handle) return String is
      use String_Mal_Hash, Ada.Strings.Unbounded;
      C : Cursor;
      Res : Unbounded_String;
   begin
      C := First (Deref (E).The_Map);
      while C /= No_Element loop
         Append (Res, Key (C) &  " => " & Types.To_String (Types.Deref (Element (C)).all) & ", ");
         C := Next (C);
      end loop;
      return To_String (Res);
   end To_String;


   -- Sym and Exprs are lists.  Bind Sets Keys in Syms to the corresponding
   -- expression in Exprs.  Returns true if all the parameters were bound.
   function Bind (Env : Env_Handle; Syms, Exprs : Types.List_Mal_Type)
   return Boolean is
      use Types;
      S, Expr : List_Mal_Type;
      First_Sym : Sym_Ptr;
   begin
      S := Syms;
      Expr := Exprs;
      while not Is_Null (S) loop

         First_Sym := Deref_Sym (Car (S));

         if First_Sym.Get_Sym = "&" then
            S := Deref_List (Cdr (S)).all;
            First_Sym := Deref_Sym (Car (S));
            Set (Env, First_Sym.Get_Sym, New_List_Mal_Type (Expr));
            return True;
         end if;

         Set (Env, First_Sym.Get_Sym, Car (Expr));
         S := Deref_List (Cdr (S)).all;
         exit when Is_Null (Expr);
         Expr := Deref_List (Cdr (Expr)).all;

      end loop;
      return Is_Null (S);
   end Bind;


   function Deref (SP : Env_Handle) return Env_Ptr is
   begin
      return Env_Ptr (Smart_Pointers.Deref (Smart_Pointers.Smart_Pointer (SP)));
   end Deref;


end Envs;