-with Ada.Text_IO;
-with Unchecked_Deallocation;
-
-package body Envs is
-
-
- procedure Set (Key : String; SP : Smart_Pointers.Smart_Pointer) is
- begin
- String_Mal_Hash.Include
- (Container => Current.The_Map,
- Key => Ada.Strings.Unbounded.To_Unbounded_String (Key),
- New_Item => SP);
- end Set;
-
- function Get (Key : String) return Smart_Pointers.Smart_Pointer is
-
- 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
- return Find (Current);
- end Get;
-
-
- function String_Hash (Key : Ada.Strings.Unbounded.Unbounded_String)
- return Ada.Containers.Hash_Type is
-
- use Ada.Containers;
- Res : Ada.Containers.Hash_Type;
- Str_Len : Natural;
- begin
- Res := 0;
- Str_Len := Ada.Strings.Unbounded.Length (Key);
- for I in 1..Str_Len loop
- Res := Res * 16 +
- Character'Pos (Ada.Strings.Unbounded.Element (Key, I));
- end loop;
- return Res;
- end String_Hash;
-
-
- 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
- TBD := Current;
- if Current.Prev_Env /= null then
- Current := Current.Prev_Env;
- Free (TBD);
- end if;
- end Delete_Env;
-
-
-end Envs;
+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 Smart_Pointer (E) = Null_Smart_Pointer;
+ end Is_Null;
+
+
+ function New_Env (Outer : 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 (E : Env_Handle; Syms, Exprs : Types.List_Mal_Type)
+ return Boolean is
+ use Types;
+ S, Expr : List_Mal_Type;
+ First_Sym : Atom_Ptr;
+ begin
+ S := Syms;
+ Expr := Exprs;
+ while not Is_Null (S) loop
+
+ First_Sym := Deref_Atom (Car (S));
+
+ if First_Sym.Get_Atom = "&" then
+ S := Deref_List (Cdr (S)).all;
+ First_Sym := Deref_Atom (Car (S));
+ Set (E, First_Sym.Get_Atom, New_List_Mal_Type (Expr));
+ return True;
+ end if;
+
+ Set (E, First_Sym.Get_Atom, 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;
+
+
+ procedure New_Env is
+ begin
+ Current := New_Env (Current);
+ end New_Env;
+
+
+ procedure Free is new Unchecked_Deallocation (Env, Env_Ptr);
+
+ procedure Delete_Env is
+ begin
+ if Debug then
+ Ada.Text_IO.Put_Line ("Deleting env at level " & Natural'Image (Deref (Current).Level));
+ end if;
+ -- Always leave one Env!
+ if not Is_Null (Deref (Current).Outer_Env) then
+ Current := Deref (Current).Outer_Env;
+ -- The old Current is finalized *if* there are no references to it.
+ -- Note closures may refer to the old env.
+ end if;
+ end Delete_Env;
+
+
+ function Get_Current return Env_Handle is
+ begin
+ return Current;
+ end Get_Current;
+
+
+ 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;
HCoop / jackhill / mal.git / blobdiff