ada/envs.adb

   1 with Ada.Text_IO;
   2 with Types;
   3 with Unchecked_Deallocation;
   4
   5 package body Envs is
   6
   7
   8    function Is_Null (E : Env_Handle) return Boolean is
   9       use Smart_Pointers;
  10    begin
  11      return Smart_Pointer (E) = Null_Smart_Pointer;
  12    end Is_Null;
  13
  14
  15    function New_Env (Outer : Env_Handle) return Env_Handle is
  16       use Smart_Pointers;
  17       Level : Natural;
  18    begin
  19       if Is_Null (Outer) then
  20          Level := 0;
  21       else
  22          Level := Deref (Outer).Level + 1;
  23       end if;
  24       if Debug then
  25          Ada.Text_IO.Put_Line
  26            ("Envs: Creating at level " & Natural'Image (Level));
  27       end if;
  28       return Env_Handle (Smart_Pointers.New_Ptr (new Env'
  29                (Base_Class with The_Map => String_Mal_Hash.Empty_Map,
  30                 Outer_Env => Outer,
  31                 Level => Level)));
  32    end New_Env;
  33
  34
  35    procedure Set
  36      (E : Env_Handle;
  37       Key : String;
  38       Elem : Smart_Pointers.Smart_Pointer) is
  39    begin
  40       if Debug then
  41          Ada.Text_IO.Put_Line
  42            ("Envs: Setting " & Key &
  43             " to " & Types.Deref (Elem).To_String &
  44             " at level " & Natural'Image (Deref (E).Level));
  45       end if;
  46       String_Mal_Hash.Include
  47         (Container => Deref (E).The_Map,
  48          Key       => Ada.Strings.Unbounded.To_Unbounded_String (Key),
  49          New_Item  => Elem);
  50    end Set;
  51
  52
  53    function Get (E : Env_Handle; Key: String)
  54    return Smart_Pointers.Smart_Pointer is
  55
  56       use String_Mal_Hash;
  57       C : Cursor;
  58
  59    begin
  60
  61       if Debug then
  62          Ada.Text_IO.Put_Line
  63            ("Envs: Finding " & Key &
  64             " at level " & Natural'Image (Deref (E).Level));
  65       end if;
  66
  67       C := Find (Deref (E).The_Map,
  68                  Ada.Strings.Unbounded.To_Unbounded_String (Key));
  69
  70       if C = No_Element then
  71
  72          if Is_Null (Deref (E).Outer_Env) then
  73             raise Not_Found;
  74          else
  75             return Get (Deref (E).Outer_Env, Key);
  76          end if;
  77
  78       else
  79          return Element (C);
  80       end if;
  81
  82    end Get;
  83
  84
  85    procedure Set_Outer
  86      (E : Env_Handle; Outer_Env : Env_Handle) is
  87    begin
  88       -- Attempt to avoid making loops.
  89       if Deref (E).Level /= 0 then
  90          Deref (E).Outer_Env := Outer_Env;
  91       end if;
  92    end Set_Outer;
  93
  94
  95    function To_String (E : Env_Handle) return String is
  96       use String_Mal_Hash, Ada.Strings.Unbounded;
  97       C : Cursor;
  98       Res : Unbounded_String;
  99    begin
 100       C := First (Deref (E).The_Map);
 101       while C /= No_Element loop
 102          Append (Res, Key (C) &  " => " & Types.To_String (Types.Deref (Element (C)).all) & ", ");
 103          C := Next (C);
 104       end loop;
 105       return To_String (Res);
 106    end To_String;
 107
 108
 109    -- Sym and Exprs are lists.  Bind Sets Keys in Syms to the corresponding
 110    -- expression in Exprs.
 111    procedure Bind (E : Env_Handle; Syms, Exprs : Types.List_Mal_Type) is
 112       use Types;
 113       S, Expr : List_Mal_Type;
 114    begin
 115       S := Syms;
 116       Expr := Exprs;
 117       while not Is_Null (S) and not Is_Null (Expr) loop
 118          Set (E, Deref_Atom (Car (S)).Get_Atom, Car (Expr));
 119          S := Deref_List (Cdr (S)).all;
 120          Expr := Deref_List (Cdr (Expr)).all;
 121       end loop;
 122    end Bind;
 123
 124
 125    function String_Hash (Key : Ada.Strings.Unbounded.Unbounded_String)
 126    return Ada.Containers.Hash_Type is
 127       use Ada.Containers;
 128       Res : Ada.Containers.Hash_Type;
 129       Str_Len : Natural;
 130    begin
 131       Res := 0;
 132       Str_Len := Ada.Strings.Unbounded.Length (Key);
 133       for I in 1..Str_Len loop
 134          Res := Res * 16 +
 135                   Character'Pos (Ada.Strings.Unbounded.Element (Key, I));
 136       end loop;
 137       return Res;
 138    end String_Hash;
 139
 140
 141    procedure New_Env is
 142    begin
 143       Current := New_Env (Current);
 144    end New_Env;
 145
 146
 147    procedure Free is new Unchecked_Deallocation (Env, Env_Ptr);
 148
 149    procedure Delete_Env is
 150    begin
 151       if Debug then
 152          Ada.Text_IO.Put_Line ("Deleting env at level " & Natural'Image (Deref (Current).Level));
 153       end if;
 154       -- Always leave one Env!
 155       if not Is_Null (Deref (Current).Outer_Env) then
 156          Current := Deref (Current).Outer_Env;
 157          -- The old Current is finalized *if* there are no references to it.
 158          -- Note closures may refer to the old env.
 159       end if;
 160    end Delete_Env;
 161
 162
 163    function Get_Current return Env_Handle is
 164    begin
 165       return Current;
 166    end Get_Current;
 167
 168
 169    function Deref (SP : Env_Handle) return Env_Ptr is
 170    begin
 171       return Env_Ptr (Smart_Pointers.Deref (Smart_Pointers.Smart_Pointer (SP)));
 172    end Deref;
 173
 174
 175 end Envs;