--| +=========================================================================+
--| |                                                                         |
--| | REFERENCE_SCAN.CONTEXT_SUPPORT (body)                                   |
--| |                                                                         |
--| | Greg Janee                                                              |
--| | General Research Corporation                                            |
--| |                                                                         |
--| +=========================================================================+

separate (Reference_Scan)
package body Context_Support is

--| We keep track of all data access context arrays we've allocated by using
--| a linked list of Array_Holder's.  Array_List heads the list.

    type Array_Holder;
    type Array_Holder_Ptr is access Array_Holder;

    type Array_Holder is
	record
	    Next : Array_Holder_Ptr;
	    A : Rvs.Data_Access_Context_Ptr;
	end record;

    Array_List : Array_Holder_Ptr;

    procedure Free is new Unchecked_Deallocation 
			     (Array_Holder, Array_Holder_Ptr);

    procedure Free is new Unchecked_Deallocation (Rvs.Data_Access_Context, 
						  Rvs.Data_Access_Context_Ptr);

--| +-------------------------------------------------------------------------+
--| | FREE_TEMPORARY_STORAGE (exported)                                       |
--| +-------------------------------------------------------------------------+

    procedure Free_Temporary_Storage is

	H : Array_Holder_Ptr;
	T : Array_Holder_Ptr;

    begin

	H := Array_List;
	while H /= null loop
	    Free (H.A);
	    T := H.Next;
	    Free (H);
	    H := T;
	end loop;

	Array_List := null;

    end Free_Temporary_Storage;

--| +-------------------------------------------------------------------------+
--| | SET/1 (exported)                                                        |
--| +-------------------------------------------------------------------------+

    function Set (The_Context : in Context; 
		  Basic_Context : in 
		     Rvs.Reference_Kinds_Or_Unknown := Rvs.Unknown; 
		  Weight : in Basic_Context_Weight := 0; 
		  New_Weight : in Basic_Context_Weight := 0; 
		  Add_Data_Access_Context : in Rvs.Data_Access_Context_Kinds; 
		  Type_Mark_Context : in 
		     Rvs.Type_Mark_Context_Kinds_Or_Unknown := Rvs.Unknown) 
		 return Context is

	H : Array_Holder_Ptr;
	Length : Integer;
	New_Context : Context;

    begin

	New_Context := The_Context;

	if Rvs."=" (The_Context.Data_Access_Context, null) then
	    Length := 1;
	else
	    Length := The_Context.Data_Access_Context'Length + 1;
	end if;

	New_Context.Data_Access_Context := 
	   new Rvs.Data_Access_Context (1 .. Length);

	New_Context.Data_Access_Context (1) := Add_Data_Access_Context;
	if Length > 1 then
	    New_Context.Data_Access_Context (2 .. Length) := 
	       The_Context.Data_Access_Context.all;
	end if;

	H := new Array_Holder;
	H.Next := Array_List;
	Array_List := H;
	H.A := New_Context.Data_Access_Context;

	return Set (New_Context, Basic_Context, Weight, 
		    New_Weight, Type_Mark_Context);

    end Set;

--| +-------------------------------------------------------------------------+
--| | SET/2 (exported)                                                        |
--| +-------------------------------------------------------------------------+

    function Set (The_Context : in Context; 
		  Basic_Context : in 
		     Rvs.Reference_Kinds_Or_Unknown := Rvs.Unknown; 
		  Weight : in Basic_Context_Weight := 0; 
		  New_Weight : in Basic_Context_Weight := 0; 
		  Type_Mark_Context : in 
		     Rvs.Type_Mark_Context_Kinds_Or_Unknown := Rvs.Unknown) 
		 return Context is

	New_Context : Context;

    begin

	New_Context := The_Context;

	if Rvs."/=" (Basic_Context, Rvs.Unknown) and 
	   Weight >= The_Context.Weight then
	    New_Context.Basic_Context := Basic_Context;
	    if New_Weight /= 0 then
		New_Context.Weight := New_Weight;
	    else
		New_Context.Weight := Weight;
	    end if;
	end if;

	if Rvs."/=" (Type_Mark_Context, Rvs.Unknown) then
	    New_Context.Type_Mark_Context := Type_Mark_Context;
	end if;

	return New_Context;

    end Set;

end Context_Support;