--| +=========================================================================+
--| |                                                                         |
--| | REFERENCE_VIEW (body)                                                   |
--| |                                                                         |
--| | Greg Janee                                                              |
--| | General Research Corporation                                            |
--| |                                                                         |
--| +=========================================================================+

with Asis_Debug_Support;
with Msg_Log;
with Quick_Sort;
with Unchecked_Deallocation;

package body Reference_View is

    Cuid : constant String := "Reference_View";
    Io_Format_Version_Number : constant Integer := 1;

--| Standard renames...

    package Asis_D renames Asis.Declarations;
    package Asis_E renames Asis.Elements;
    package Asis_En renames Asis.Environment;
    package Asis_Num renames Asis.Numerics;
    package Asis_Str renames Asis.Strings;
    package Asis_Td renames Asis.Type_Definitions;
    package Asis_Txt renames Asis.Text;
    package Asis_X renames Asis.Expressions;

--| Support for hashing.  References are collected in Temporary_Collection's,
--| which are hashed into The_Hash_Table, an open hash table.  The list
--| headed by Reference_List is in source code order.

    type Temporary_Reference_Holder;
    type Temporary_Reference_Holder_Ptr is access Temporary_Reference_Holder;

    type Temporary_Reference_Holder is
	record
	    Next : Temporary_Reference_Holder_Ptr;
	    Reference : Rvs.Reference;
	end record;

    Hash_Table_Size : constant Integer := 1009;
    subtype Hash_Table_Index is Integer range 0 .. Hash_Table_Size - 1;

    type Temporary_Collection;
    type Temporary_Collection_Ptr is access Temporary_Collection;

    type Temporary_Collection is
	record
	    Next_In_Bucket : Temporary_Collection_Ptr;
	    Entity : Asis.Element;
	    Number_References : Integer := 0;
	    Reference_List : Temporary_Reference_Holder_Ptr;
	end record;

    type Hash_Table is array (Hash_Table_Index) of Temporary_Collection_Ptr;
    The_Hash_Table : Hash_Table;

    Number_Collections : Integer;

--| Instantiations.

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

    procedure Free is new Unchecked_Deallocation 
			     (Rvs.Reference_Context, Rvs.Reference_Context_Ptr);

    procedure Free is new Unchecked_Deallocation 
			     (Rvs.Collected_References_Set, 
			      Rvs.Collected_References_Set_Ptr);

    procedure Free_View is 
       new Unchecked_Deallocation 
	      (Rvs.Collected_References_Set_Ptr_List, Rvs.Reference_View);

    procedure Free is new Unchecked_Deallocation 
			     (Temporary_Reference_Holder, 
			      Temporary_Reference_Holder_Ptr);

    procedure Free is new Unchecked_Deallocation 
			     (Temporary_Collection, Temporary_Collection_Ptr);

    package Asis_Id_Cnt_Io is new Text_Io.Integer_Io (Asis_Id_Io.Count);
    package Asis_Int_Io is new Text_Io.Integer_Io (Asis.Asis_Integer);
    package Dac_Kind_Io is new Text_Io.Enumeration_Io 
				  (Rvs.Data_Access_Context_Kinds);
    package Int_Io is new Text_Io.Integer_Io (Integer);
    package Ref_Kind_Io is new Text_Io.Enumeration_Io (Rvs.Reference_Kinds);
    package Tmc_Kind_Io is new Text_Io.Enumeration_Io 
				  (Rvs.Type_Mark_Context_Kinds);

--| Local subprograms.

    function "<=" (Left : in Rvs.Reference; Right : in Rvs.Reference) 
		  return Boolean;

    procedure Asis_Failed_Error 
		 (Current_Element : in Asis.Element; Program_Unit : in String);

    procedure Asis_Inappropriate_Element_Error 
		 (Current_Element : in Asis.Element; Program_Unit : in String);

    procedure Clear_Hash_Table;

    function Diagnosis return String;

    function Hash_Asis_Element 
		(The_Element : in Asis.Element) return Hash_Table_Index;

    procedure Load_Hash_Table_From_Scan_List;

    procedure Load_Hash_Table_From_View (The_View : in Rvs.Reference_View);

    procedure Load_Reference 
		 (C : in Temporary_Collection_Ptr; R : in Rvs.Reference);

    function Locate_Collection (The_Entity : in Asis.Element) 
			       return Temporary_Collection_Ptr;

    function Package_Collections return Rvs.Reference_View;

    function "<" (Left, Right : in Rvs.Collected_References_Set_Ptr) 
		 return Boolean;

    package Entity_Name_Sort is 
       new Quick_Sort (Item => Rvs.Collected_References_Set_Ptr, 
		       Index => Integer, 
		       Items => Rvs.Collected_References_Set_Ptr_List, 
		       "<" => "<");


--| +-------------------------------------------------------------------------+
--| | "<" (local)                                                             |
--| +-------------------------------------------------------------------------+
--|
--| Returns true if the name string of the left entity is lexicographically
--| less than the name string of the right entity.

    function "<" (Left, Right : in Rvs.Collected_References_Set_Ptr) 
		 return Boolean is

	Puid : constant String := """<""";

	Current_Element : Asis.Element;
	Left_Entity : Asis.Entity_Name_Definition;
	Right_Entity : Asis.Entity_Name_Definition;

	function Get_Entity_Definition (S : Rvs.Collected_References_Set_Ptr) 
				       return Asis.Entity_Name_Definition is
	    Entity_Declaration : Asis.Declaration;
	begin
	    if Asis_E."=" (Asis_E.Element_Kind (S.Entity_Definition), 
			   Asis_E.A_Type_Definition) then
		Current_Element := S.Entity_Definition;
		Entity_Declaration := 
		   Asis_E.Enclosing_Element (Current_Element);
		Current_Element := Entity_Declaration;
		declare
		    Names : constant Asis.Entity_Name_Definition_List := 
		       Asis_D.Names (Current_Element);
		begin
		    return Names (1);
		end;
	    else
		return S.Entity_Definition;
	    end if;
	end Get_Entity_Definition;

    begin -- "<"

	Left_Entity := Get_Entity_Definition (Left);
	Right_Entity := Get_Entity_Definition (Right);
	Current_Element := Left_Entity;
	declare
	    Left_String : constant String := Asis_X.Name (Current_Element);
	begin
	    Current_Element := Right_Entity;
	    declare
		Right_String : constant String := Asis_X.Name (Current_Element);
	    begin
		return Left_String < Right_String;
	    end;
	end;

    exception

	when Asis.Asis_Inappropriate_Element =>
	    Asis_Inappropriate_Element_Error (Current_Element, Puid);
	    raise Reference_View.Traversal_Error;

	when Asis.Asis_Failed =>
	    Asis_Failed_Error (Current_Element, Puid);
	    raise Reference_View.Traversal_Error;

    end "<";

--| +-------------------------------------------------------------------------+
--| | "<=" (local)                                                            |
--| +-------------------------------------------------------------------------+
--|
--| Returns true if the left reference precedes the right reference in the
--| source code.  (Of course, this is meaningful only if the references
--| are in the same source file.)

    function "<=" (Left : in Rvs.Reference; Right : in Rvs.Reference) 
		  return Boolean is

	Puid : constant String := """<=""";

	Current_Element : Asis.Element;
	Lspan : Asis.Span;
	Rspan : Asis.Span;

    begin

	Current_Element := Left.Reference_Element;
	Lspan := Asis_Txt.Element_Span (Current_Element);
	Current_Element := Right.Reference_Element;
	Rspan := Asis_Txt.Element_Span (Current_Element);

	return Asis_Num."<" (Lspan.First_Line, Rspan.First_Line) or 
		  (Asis_Num."=" (Lspan.First_Line, Rspan.First_Line) and 
		   Asis_Num."<=" (Rspan.First_Column, Rspan.First_Column));

    exception

	when Asis.Asis_Inappropriate_Element =>
	    Asis_Inappropriate_Element_Error (Current_Element, Puid);
	    raise Reference_View.Traversal_Error;

	when Asis.Asis_Failed =>
	    Asis_Failed_Error (Current_Element, Puid);
	    raise Reference_View.Traversal_Error;

    end "<=";

--| +-------------------------------------------------------------------------+
--| | ASIS_FAILED_ERROR (local)                                               |
--| +-------------------------------------------------------------------------+

    procedure Asis_Failed_Error (Current_Element : in Asis.Element; 
				 Program_Unit : in String) is
    begin

	Msg_Log.Put_Msg_Debug 
	   ("exception Asis_Failed raised; current element is " & 
	    Asis_Debug_Support.Element_Image (Current_Element) & 
	    "; status is " & Asis_En.Error_Kinds'Image (Asis_En.Status) & 
	    "; diagnosis follows");
	Msg_Log.Put_Msg_Debug (Cuid, Program_Unit, Diagnosis);

    end Asis_Failed_Error;

--| +-------------------------------------------------------------------------+
--| | ASIS_INAPPROPRIATE_ELEMENT_ERROR (local)                                |
--| +-------------------------------------------------------------------------+

    procedure Asis_Inappropriate_Element_Error 
		 (Current_Element : in Asis.Element; 
		  Program_Unit : in String) is
    begin

	Msg_Log.Put_Msg_Debug 
	   ("exception Asis_Inappropriate_Element raised; " & 
	    "current element is " & 
	    Asis_Debug_Support.Element_Image (Current_Element) & 
	    "; status is " & Asis_En.Error_Kinds'Image (Asis_En.Status) & 
	    "; diagnosis follows");
	Msg_Log.Put_Msg_Debug (Cuid, Program_Unit, Diagnosis);

    end Asis_Inappropriate_Element_Error;

--| +-------------------------------------------------------------------------+
--| | CLEAR_HASH_TABLE (local)                                                |
--| +-------------------------------------------------------------------------+
--|
--| Frees all temporary memory held by the hash table, and sets every
--| hash table entry to null.

    procedure Clear_Hash_Table is

	C : Temporary_Collection_Ptr;
	H : Temporary_Reference_Holder_Ptr;
	Tc : Temporary_Collection_Ptr;
	Th : Temporary_Reference_Holder_Ptr;

    begin

	for I in The_Hash_Table'Range loop
	    C := The_Hash_Table (I);
	    while C /= null loop
		H := C.Reference_List;
		while H /= null loop
		    Th := H.Next;
		    Free (H);
		    H := Th;
		end loop;
		Tc := C.Next_In_Bucket;
		Free (C);
		C := Tc;
	    end loop;
	    The_Hash_Table (I) := null;
	end loop;

    end Clear_Hash_Table;

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

    procedure Construct (The_View : in out Rvs.Reference_View; 
			 For_Unit : in Asis.Compilation_Unit; 
			 Include_Pragmas : in Boolean := True; 
			 Normalize_Associations : in Boolean := False; 
			 Expand_Instantiations : in Boolean := False; 
			 Trace : in Boolean := False) is
    begin

	Reference_Scan.Obeying_Regions := False;
	Reference_Scan.Include_All_Pragmas (Include_Pragmas);
	Reference_Scan.Normalize_All_Associations (Normalize_Associations);
	Reference_Scan.Expand_All_Instantiations (Expand_Instantiations);

	if Trace then
	    Reference_Scan.Start_Trace;
	end if;

	Reference_Scan.Scan_Compilation_Unit 
	   (For_Unit, Reference_Scan.Starting_Context);

	if Trace then
	    Reference_Scan.Stop_Trace;
	end if;

	Reference_Scan.Free_Temporary_Storage;

	Number_Collections := 0;
	if Rvs."/=" (The_View, null) then
	    Load_Hash_Table_From_View (The_View);
	    Free (The_View);
	end if;
	Load_Hash_Table_From_Scan_List;

	The_View := Package_Collections;

	Clear_Hash_Table;
	Reference_Scan.Free_Holder_List;

    exception

	when Reference_Scan.Traversal_Error =>
	    raise Reference_View.Traversal_Error;

    end Construct;

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

    procedure Construct (The_View : in out Rvs.Reference_View; 
			 For_Region : in Region_Support.Region; 
			 Include_Pragmas : in Boolean := True; 
			 Normalize_Associations : in Boolean := False; 
			 Expand_Instantiations : in Boolean := False; 
			 Trace : in Boolean := False) is
    begin

	Reference_Scan.Obeying_Regions := True;
	Reference_Scan.Include_All_Pragmas (Include_Pragmas);
	Reference_Scan.Normalize_All_Associations (Normalize_Associations);
	Reference_Scan.Expand_All_Instantiations (Expand_Instantiations);

	if Trace then
	    Reference_Scan.Start_Trace;
	end if;

	Reference_Scan.Scan_Declarative_Region_Part 
	   (For_Region, Reference_Scan.Starting_Context);

	if Trace then
	    Reference_Scan.Stop_Trace;
	end if;

	Reference_Scan.Free_Temporary_Storage;

	Number_Collections := 0;
	if Rvs."/=" (The_View, null) then
	    Load_Hash_Table_From_View (The_View);
	    Free (The_View);
	end if;
	Load_Hash_Table_From_Scan_List;

	The_View := Package_Collections;

	Clear_Hash_Table;
	Reference_Scan.Free_Holder_List;

    exception

	when Reference_Scan.Traversal_Error =>
	    raise Reference_View.Traversal_Error;

    end Construct;

--| +-------------------------------------------------------------------------+
--| | DIAGNOSIS (local)                                                       |
--| +-------------------------------------------------------------------------+

    function Diagnosis return String is

	Asis_Diagnosis : constant String := 
	   Asis_Str.To_Standard_String (Asis_En.Diagnosis);

    begin

	if Asis_Diagnosis = "" then
	    return "<no diagnosis available>";
	else
	    return Asis_Diagnosis;
	end if;

    end Diagnosis;

--| +-------------------------------------------------------------------------+
--| | DUMP (exported)                                                         |
--| +-------------------------------------------------------------------------+

    procedure Dump (The_View : in Rvs.Reference_View; 
		    To_The_File : in Text_Io.File_Type := 
		       Text_Io.Standard_Output) is

	Puid : constant String := "Dump";

	Copy : Rvs.Collected_References_Set_Ptr_List (The_View'Range);
	Current_Element : Asis.Element;
	Entity_Declaration : Asis.Declaration;
	F : Text_Io.File_Type renames To_The_File;
	S : Rvs.Collected_References_Set_Ptr;
	Span : Asis.Span;


    begin

	if Rvs."=" (The_View, null) then
	    return;
	end if;

	-- Make a copy of top-level array in the view and sort the copy
	-- by entity name.

	Copy := The_View.all;
	Entity_Name_Sort.Sort (Copy);

	for I in Copy'Range loop
	    S := Copy (I);
	    Text_Io.New_Line (F);
	    Text_Io.Put (F, Asis_Debug_Support.Element_Image 
			       (S.Entity_Definition));
	    if Asis_E."=" (Asis_E.Element_Kind (S.Entity_Definition), 
			   Asis_E.A_Type_Definition) then
		Current_Element := S.Entity_Definition;
		Entity_Declaration := 
		   Asis_E.Enclosing_Element (Current_Element);
		Current_Element := Entity_Declaration;
		declare
		    Names : constant Asis.Entity_Name_Definition_List := 
		       Asis_D.Names (Current_Element);
		begin
		    Current_Element := Names (1);
		    Text_Io.Put (F, 
				 " """ & Asis_X.Name (Current_Element) & """");
		end;
	    end if;
	    Text_Io.New_Line (F);
	    for J in S.References'Range loop
		declare
		    R : Rvs.Reference renames S.References (J);
		begin
		    Current_Element := R.Reference_Element;
		    Span := Asis_Txt.Element_Span (Current_Element);
		    Text_Io.Put (F, "   ");
		    Asis_Int_Io.Put (F, Span.First_Line, 3);
		    Text_Io.Put (F, " ");
		    Asis_Int_Io.Put (F, Span.First_Column, 3);
		    Text_Io.Put (F, " " & Rvs.Reference_Kinds'Image 
					     (R.Context.Kind));
		    case R.Context.Kind is
			when Rvs.A_Read | Rvs.An_Update | 
			     Rvs.A_Read_And_Update =>
			    Text_Io.Put (F, " (");
			    for K in R.Context.Data_Access_Context'Range loop
				if K > R.Context.Data_Access_Context'First then
				    Text_Io.Put (F, " ");
				end if;
				Text_Io.Put 
				   (F, Rvs.Data_Access_Context_Kinds'Image 
					  (R.Context.Data_Access_Context (K)));
			    end loop;
			    Text_Io.Put (F, ")");
			when Rvs.A_Type_Mark =>
			    Text_Io.Put 
			       (F, " (" & Rvs.Type_Mark_Context_Kinds'Image 
					     (R.Context.Type_Mark_Context) & 
				      ")");
			when others =>
			    null;
		    end case;
		    Text_Io.New_Line (F);
		end;
	    end loop;
	end loop;

    exception

	when Asis.Asis_Inappropriate_Element =>
	    Asis_Inappropriate_Element_Error (Current_Element, Puid);
	    raise Reference_View.Traversal_Error;

	when Asis.Asis_Failed =>
	    Asis_Failed_Error (Current_Element, Puid);
	    raise Reference_View.Traversal_Error;

    end Dump;

--| +-------------------------------------------------------------------------+
--| | FREE (exported)                                                         |
--| +-------------------------------------------------------------------------+

    procedure Free (The_View : in out Rvs.Reference_View) is

	S : Rvs.Collected_References_Set_Ptr;

    begin

	if Rvs."=" (The_View, null) then
	    return;
	end if;

	for I in The_View'Range loop
	    S := The_View (I);
	    for J in S.References'Range loop
		declare
		    R : Rvs.Reference renames S.References (J);
		begin
		    if Rvs."=" (R.Context.Kind, Rvs.A_Read) or 
		       Rvs."=" (R.Context.Kind, Rvs.An_Update) or 
		       Rvs."=" (R.Context.Kind, Rvs.A_Read_And_Update) then
			Free (R.Context.Data_Access_Context);
		    end if;
		    Free (R.Context);
		end;
	    end loop;
	    Free (S);
	end loop;

	Free_View (The_View);

    end Free;

--| +-------------------------------------------------------------------------+
--| | HASH_ASIS_ELEMENT (local)                                               |
--| +-------------------------------------------------------------------------+
--|
--| Hashes an arbitrary Asis element, producing a Hash_Table_Index.

    function Hash_Asis_Element 
		(The_Element : in Asis.Element) return Hash_Table_Index is

	Puid : constant String := "Hash_Asis_Element";

    begin

	return Integer (Asis_E.Operations.Hash (The_Element)) mod 
		  Hash_Table_Size;

    exception

	when Asis.Asis_Inappropriate_Element =>
	    Asis_Inappropriate_Element_Error (The_Element, Puid);
	    raise Reference_View.Traversal_Error;

	when Asis.Asis_Failed =>
	    Asis_Failed_Error (The_Element, Puid);
	    raise Reference_View.Traversal_Error;

    end Hash_Asis_Element;

--| +-------------------------------------------------------------------------+
--| | INPUT (exported)                                                        |
--| +-------------------------------------------------------------------------+
--|
--| This function should really do some validity checking on the input files.

    function Input (From_Control_File : in Text_Io.File_Type; 
		    From_Id_File : in Asis_Id_Io.File_Type; 
		    Library : Asis.Library) return Rvs.Reference_View is

	Puid : constant String := "Input";

	Cfile : Text_Io.File_Type renames From_Control_File;
	Data_Access_Context_Length : Integer;
	Header : String (1 .. 14);
	Ifile : Asis_Id_Io.File_Type renames From_Id_File;
	Is_Collection_Reference : Boolean;
	Number_Collections : Integer;
	Number_References : Integer;
	Position : Asis_Id_Io.Count;
	Reference_Kind : Rvs.Reference_Kinds;
	The_View : Rvs.Reference_View;
	Version : Integer;

    begin

	Text_Io.Get (Cfile, Header);
	Int_Io.Get (Cfile, Version);

	Int_Io.Get (Cfile, Number_Collections);
	The_View := new Rvs.Collected_References_Set_Ptr_List 
			   (1 .. Number_Collections);

	for I in The_View'Range loop
	    Int_Io.Get (Cfile, Number_References);
	    The_View (I) := new Rvs.Collected_References_Set 
				   (Number_References);
	    Asis_Id_Cnt_Io.Get (Cfile, Position);
	    Asis_Id_Io.Read (Ifile, The_View (I).Entity_Definition, 
			     Position, Library);
	    Is_Collection_Reference := 
	       Asis_E."=" (Asis_E.Element_Kind (The_View (I).Entity_Definition), 
			   Asis_E.A_Type_Definition);
	    for J in The_View (I).References'Range loop
		declare
		    R : Rvs.Reference renames The_View (I).References (J);
		begin
		    Asis_Id_Cnt_Io.Get (Cfile, Position);
		    Asis_Id_Io.Read (Ifile, R.Reference_Element, 
				     Position, Library);
		    Ref_Kind_Io.Get (Cfile, Reference_Kind);
		    R.Context := new Rvs.Reference_Context (Reference_Kind);
		    case Reference_Kind is
			when Rvs.A_Read | Rvs.An_Update | 
			     Rvs.A_Read_And_Update =>
			    Int_Io.Get (Cfile, Data_Access_Context_Length);
			    R.Context.Data_Access_Context := 
			       new Rvs.Data_Access_Context 
				      (1 .. Data_Access_Context_Length);
			    for K in R.Context.Data_Access_Context'Range loop
				Dac_Kind_Io.Get 
				   (Cfile, R.Context.Data_Access_Context (K));
			    end loop;
			when Rvs.A_Type_Mark =>
			    Tmc_Kind_Io.Get (Cfile, 
					     R.Context.Type_Mark_Context);
			when others =>
			    null;
		    end case;
		    R.Is_Collection_Reference := Is_Collection_Reference;
		end;
	    end loop;
	end loop;

	return The_View;

    exception

	when Asis.Asis_Failed =>
	    Asis_Failed_Error (Asis.Nil_Element, Puid);
	    raise Reference_View.Traversal_Error;

    end Input;

--| +-------------------------------------------------------------------------+
--| | LOAD_HASH_TABLE_FROM_SCAN_LIST (local)                                  |
--| +-------------------------------------------------------------------------+
--|
--| Loads the hash table from the list of references produced by the
--| reference scan.

    procedure Load_Hash_Table_From_Scan_List is

	Puid : constant String := "Load_Hash_Table_From_Scan_List";

	C : Temporary_Collection_Ptr;
	Current_Element : Asis.Element;
	Entity : Asis.Element;
	Expression_Type : Asis.Type_Definition;
	H : Reference_Scan.Reference_Holder_Ptr;

    begin

	H := Reference_Scan.Reference_List;
	while Reference_Scan."/=" (H, null) loop
	    if H.Reference.Is_Collection_Reference then
		Current_Element := H.Reference.Reference_Element;
		Expression_Type := Asis_X.Expression_Type (Current_Element);
		Current_Element := Expression_Type;
		Entity := Asis_Td.Ground_Type (Current_Element);
	    else
		Current_Element := H.Reference.Reference_Element;
		Entity := Asis_X.Name_Definition (Current_Element);
	    end if;
	    C := Locate_Collection (Entity);
	    Load_Reference (C, H.Reference);
	    H := H.Next;
	end loop;

    exception

	when Asis.Asis_Inappropriate_Element =>
	    Asis_Inappropriate_Element_Error (Current_Element, Puid);
	    raise Reference_View.Traversal_Error;

	when Asis.Asis_Failed =>
	    Asis_Failed_Error (Current_Element, Puid);
	    raise Reference_View.Traversal_Error;

    end Load_Hash_Table_From_Scan_List;

--| +-------------------------------------------------------------------------+
--| | LOAD_HASH_TABLE_FROM_VIEW (local)                                       |
--| +-------------------------------------------------------------------------+
--|
--| Loads the hash table from a previously constructed, non-null
--| reference view.

    procedure Load_Hash_Table_From_View (The_View : in Rvs.Reference_View) is

	C : Temporary_Collection_Ptr;
	New_R : Rvs.Reference;

    begin

	for I in The_View'Range loop
	    C := Locate_Collection (The_View (I).Entity_Definition);
	    for J in reverse The_View (I).References'Range loop
		declare
		    R : Rvs.Reference renames The_View (I).References (J);
		begin
		    New_R.Reference_Element := R.Reference_Element;
		    New_R.Context := new Rvs.Reference_Context (R.Context.Kind);
		    case R.Context.Kind is
			when Rvs.A_Read | Rvs.An_Update | 
			     Rvs.A_Read_And_Update =>
			    New_R.Context.Data_Access_Context := 
			       new Rvs.Data_Access_Context 
				      (R.Context.Data_Access_Context'Range);
			    New_R.Context.Data_Access_Context.all := 
			       R.Context.Data_Access_Context.all;
			when Rvs.A_Type_Mark =>
			    New_R.Context.Type_Mark_Context := 
			       R.Context.Type_Mark_Context;
			when others =>
			    null;
		    end case;
		    New_R.Is_Collection_Reference := R.Is_Collection_Reference;
		    Load_Reference (C, New_R);
		end;
	    end loop;
	end loop;

    end Load_Hash_Table_From_View;

--| +-------------------------------------------------------------------------+
--| | LOAD_REFERENCE (local)                                                  |
--| +-------------------------------------------------------------------------+
--|
--| Adds a reference to a temporary collection in source code order.

    procedure Load_Reference 
		 (C : in Temporary_Collection_Ptr; R : in Rvs.Reference) is

	H : Temporary_Reference_Holder_Ptr;
	New_H : Temporary_Reference_Holder_Ptr;
	Previous_H : Temporary_Reference_Holder_Ptr;

    begin

	New_H := new Temporary_Reference_Holder;
	New_H.Reference := R;

	H := C.Reference_List;
	while H /= null and then not (R <= H.Reference) loop
	    Previous_H := H;
	    H := H.Next;
	end loop;

	if Previous_H = null then
	    C.Reference_List := New_H;
	else
	    Previous_H.Next := New_H;
	end if;
	New_H.Next := H;

	C.Number_References := C.Number_References + 1;

    end Load_Reference;

--| +-------------------------------------------------------------------------+
--| | LOCATE_COLLECTION (local)                                               |
--| +-------------------------------------------------------------------------+
--|
--| Locates the temporary collection in the hash table for an entity,
--| creating one if necessary.

    function Locate_Collection (The_Entity : in Asis.Element) 
			       return Temporary_Collection_Ptr is

	C : Temporary_Collection_Ptr;
	I : Hash_Table_Index;

    begin

	I := Hash_Asis_Element (The_Entity);
	C := The_Hash_Table (I);
	while C /= null loop
	    if Asis_E.Is_Equal (The_Entity, C.Entity) then
		return C;
	    end if;
	    C := C.Next_In_Bucket;
	end loop;

	C := new Temporary_Collection;
	C.Next_In_Bucket := The_Hash_Table (I);
	The_Hash_Table (I) := C;
	C.Entity := The_Entity;

	Number_Collections := Number_Collections + 1;

	return C;

    end Locate_Collection;

--| +-------------------------------------------------------------------------+
--| | MERGE (exported)                                                        |
--| +-------------------------------------------------------------------------+

    function Merge (The_View : in Rvs.Reference_View; 
		    And_The_View : in Rvs.Reference_View) 
		   return Rvs.Reference_View is

	New_View : Rvs.Reference_View;

    begin

	Number_Collections := 0;
	if Rvs."/=" (The_View, null) then
	    Load_Hash_Table_From_View (The_View);
	end if;
	if Rvs."/=" (And_The_View, null) then
	    Load_Hash_Table_From_View (And_The_View);
	end if;

	New_View := Package_Collections;

	Clear_Hash_Table;

	return New_View;

    end Merge;

--| +-------------------------------------------------------------------------+
--| | OUTPUT (exported)                                                       |
--| +-------------------------------------------------------------------------+

    procedure Output (The_View : in Rvs.Reference_View; 
		      To_Control_File : in Text_Io.File_Type; 
		      To_Id_File : in Asis_Id_Io.File_Type) is

	Puid : constant String := "Output";

	Cfile : Text_Io.File_Type renames To_Control_File;
	Current_Element : Asis.Element;
	Ifile : Asis_Id_Io.File_Type renames To_Id_File;
	S : Rvs.Collected_References_Set_Ptr;

    begin

	Text_Io.Put (Cfile, "REFERENCE VIEW ");
	Int_Io.Put (Cfile, Io_Format_Version_Number, 0);
	Text_Io.New_Line (Cfile);

	if Rvs."=" (The_View, null) then
	    Text_Io.Put_Line (Cfile, "0");
	    return;
	else
	    Int_Io.Put (Cfile, The_View'Length, 0);
	    Text_Io.New_Line (Cfile);
	end if;

	for I in The_View'Range loop
	    S := The_View (I);
	    Int_Io.Put (Cfile, S.Number_References, 0);
	    Text_Io.Put (Cfile, " ");
	    Asis_Id_Cnt_Io.Put (Cfile, Asis_Id_Io.Index (Ifile), 0);
	    Current_Element := S.Entity_Definition;
	    Asis_Id_Io.Write (Ifile, Current_Element);
	    Text_Io.New_Line (Cfile);
	    for J in S.References'Range loop
		declare
		    R : Rvs.Reference renames S.References (J);
		begin
		    Asis_Id_Cnt_Io.Put (Cfile, Asis_Id_Io.Index (Ifile), 0);
		    Current_Element := R.Reference_Element;
		    Asis_Id_Io.Write (Ifile, Current_Element);
		    Text_Io.Put (Cfile, " " & Rvs.Reference_Kinds'Image 
						 (R.Context.Kind));
		    case R.Context.Kind is
			when Rvs.A_Read | Rvs.An_Update | 
			     Rvs.A_Read_And_Update =>
			    Text_Io.Put (Cfile, " ");
			    Int_Io.Put 
			       (Cfile, R.Context.Data_Access_Context'Length, 0);
			    for K in R.Context.Data_Access_Context'Range loop
				Text_Io.Put 
				   (Cfile, 
				    " " & Rvs.Data_Access_Context_Kinds'Image 
					     (R.Context.Data_Access_Context 
						 (K)));
			    end loop;
			when Rvs.A_Type_Mark =>
			    Text_Io.Put 
			       (Cfile, " " & Rvs.Type_Mark_Context_Kinds'Image 
						(R.Context.Type_Mark_Context));
			when others =>
			    null;
		    end case;
		    Text_Io.New_Line (Cfile);
		end;
	    end loop;
	end loop;

    exception

	when Asis.Asis_Inappropriate_Element =>
	    Asis_Inappropriate_Element_Error (Current_Element, Puid);
	    raise Reference_View.Traversal_Error;

	when Asis.Asis_Failed =>
	    Asis_Failed_Error (Current_Element, Puid);
	    raise Reference_View.Traversal_Error;

    end Output;

--| +-------------------------------------------------------------------------+
--| | PACKAGE_COLLECTIONS (local)                                             |
--| +-------------------------------------------------------------------------+
--|
--| Packages the temporary collections into a reference view.

    function Package_Collections return Rvs.Reference_View is

	C : Temporary_Collection_Ptr;
	H : Temporary_Reference_Holder_Ptr;
	J : Integer;
	K : Integer;
	The_View : Rvs.Reference_View;

    begin

	The_View := new Rvs.Collected_References_Set_Ptr_List 
			   (1 .. Number_Collections);

	J := 0;
	for I in The_Hash_Table'Range loop
	    C := The_Hash_Table (I);
	    while C /= null loop
		J := J + 1;
		The_View (J) := new Rvs.Collected_References_Set 
				       (C.Number_References);
		The_View (J).Entity_Definition := C.Entity;
		K := 0;
		H := C.Reference_List;
		while H /= null loop
		    K := K + 1;
		    The_View (J).References (K) := H.Reference;
		    H := H.Next;
		end loop;
		C := C.Next_In_Bucket;
	    end loop;
	end loop;

	return The_View;

    end Package_Collections;

end Reference_View;