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

with Unchecked_Deallocation;

package body Reference_Scan is

--| Standard renames...

    package Asis_Cu renames Asis.Compilation_Units;
    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_Rc renames Asis.Representation_Clauses;
    package Asis_S renames Asis.Statements;
    package Asis_Str renames Asis.Strings;
    package Asis_Td renames Asis.Type_Definitions;
    package Asis_X renames Asis.Expressions;

--| Support for tracing.  Start, Stop, and On implement the corresponding
--| subprograms exported by this package.  Add_Level creates a new trace level
--| having the indicated number of children.  Add_Children adds
--| children to the current trace level.  Log writes a textual
--| representation of an element to the trace file along with the current
--| context.  Every scan procedure in this package follows the same
--| general outline, namely:
--|
--|     if Trace_Support.On then
--|         Trace_Support.Log (<current element>, <current context>);
--|     end if;
--|     <gather children>
--|     if Trace_Support.On then
--|         Trace_Support.Add_Level (<number of children>);
--|     end if;
--|     <scan children>

    package Trace_Support is

	procedure Start;

	procedure Stop;

	function On return Boolean;

	procedure Add_Level (Number_Children : in Natural);

	procedure Add_Children (Number_Children : in Natural);

	procedure Log (The_Unit : in Asis.Compilation_Unit; 
		       The_Context : in Context);

	procedure Log (The_Element : in Asis.Element; 
		       The_Context : in Context; 
		       Is_Reference : in Boolean := False);

    end Trace_Support;

    package body Trace_Support is separate;

--| Bodies of the exported trace subprograms.

    procedure Start_Trace is
    begin
	Trace_Support.Start;
    end Start_Trace;

    procedure Stop_Trace is
    begin
	Trace_Support.Stop;
    end Stop_Trace;

    function Trace_On return Boolean is
    begin
	return Trace_Support.On;
    end Trace_On;

--| Error handling.  Log writes a message using the Msg_Log package.
--| The error kind A_Previous_Error is used to produce a stack traceback,
--| i.e., every scan procedure in this package has exception handlers
--| of the form:
--|
--|     when Asis_Inappropriate_Element =>
--|         Error_Handling_Support.Log (A_Bad_Element, ...);
--|         raise Traversal_Error;
--|
--|     when Asis_Failed =>
--|         Error_Handling_Support.Log (An_Asis_Failure, ...);
--|         raise Traversal_Error;
--|
--|     when Traversal_Error =>
--|         Error_Handling_Support.Log (A_Previous_Error, ...);
--|         raise;
--|
--| Semantic_Error logs a semantic traversal error.  Step_Descriptions
--| describes the traversal steps taken.  It should consist of one or more
--| substrings, each terminated by a period.  For example, if Steps contains
--| three elements (an expression, its type, and the corresponding
--| ground type), Step_Descriptions might be:
--|
--|     "starting from.expression type.ground type."
--|
--| Malformed_Reference_Error notes a malformed reference.

    package Error_Handling_Support is

	type Error_Kinds is (A_Previous_Error, An_Unhandled_Case, 
			     An_Asis_Failure, A_Bad_Element);

	procedure Log (Error_Kind : in Error_Kinds; 
		       Library_Unit : in String; 
		       Program_Unit : in String; 
		       Current_Unit : in Asis.Compilation_Unit);

	procedure Log (Error_Kind : in Error_Kinds; 
		       Library_Unit : in String; 
		       Program_Unit : in String; 
		       Current_Element : in Asis.Element);

	procedure Semantic_Error (Cause : in String; 
				  Step_Descriptions : in String; 
				  Steps : in Asis.Element_List; 
				  Library_Unit : in String; 
				  Program_Unit : in String);

	procedure Malformed_Reference_Error 
		     (Current_Element : in Asis.Element; Problem : in String);

    end Error_Handling_Support;

    package body Error_Handling_Support is separate;

--| Convenience subprograms.  One_If_Present returns 1 if the given element
--| is non-nil and 0 otherwise.  It is used to allow arithmetic computations to
--| be affected by the presence of optional syntactic categories.
--| One_If_True is a similar function for boolean flags.

    procedure Include_All_Pragmas (Yes : in Boolean) is
    begin
	Include_Accept_Statement_Pragmas := Yes;
	Include_Block_Statement_Pragmas := Yes;
	Include_Case_Statement_Pragmas := Yes;
	Include_Context_Clause_Pragmas := Yes;
	Include_Exception_Handler_Pragmas := Yes;
	Include_Generic_Formal_Part_Pragmas := Yes;
	Include_If_Statement_Pragmas := Yes;
	Include_Loop_Statement_Pragmas := Yes;
	Include_Package_Pragmas := Yes;
	Include_Record_Representation_Clause_Pragmas := Yes;
	Include_Record_Type_Definition_Pragmas := Yes;
	Include_Select_Statement_Pragmas := Yes;
	Include_Task_Declaration_Pragmas := Yes;
	Include_Task_Type_Definition_Pragmas := Yes;
    end Include_All_Pragmas;

    procedure Normalize_All_Associations (Yes : in Boolean) is
    begin
	Normalize_Discriminant_Constraint_Components := Yes;
	Normalize_Entry_Call_Parameters := Yes;
	Normalize_Function_Call_Parameters := Yes;
	Normalize_Instantiation_Parameters := Yes;
	Normalize_Procedure_Call_Parameters := Yes;
	Normalize_Record_Aggregate_Components := Yes;
    end Normalize_All_Associations;

    procedure Expand_All_Instantiations (Yes : in Boolean) is
    begin
	Expand_Procedure_Instantiations := Yes;
	Expand_Function_Instantiations := Yes;
	Expand_Package_Instantiations := Yes;
    end Expand_All_Instantiations;

    function One_If_Present (The_Element : in Asis.Element) return Integer is
    begin
	if Asis_E.Is_Nil (The_Element) then
	    return 0;
	else
	    return 1;
	end if;
    end One_If_Present;

    function One_If_True (Flag : in Boolean) return Integer is
    begin
	if Flag = True then
	    return 1;
	else
	    return 0;
	end if;
    end One_If_True;

--| Support for modifying the context.  The basic context is set (if it is
--| not Unknown, of course) if Weight is greater than or equal to
--| the weight of the current context assignment.  If New_Weight is nonzero,
--| it becomes the weight of the new assignment; otherwise, the weight
--| of the new assignment is Weight.  The Add_Data_Access_Context argument
--| adds (i.e., prepends) a data access context to the current list.
--| The Type_Mark_Context argument sets the type mark context if it is not
--| Unknown.  Free_Temporary_Storage frees up all data access context arrays
--| that have been allocated by this package.

    package Context_Support is

	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;

	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;

	procedure Free_Temporary_Storage;

    end Context_Support;

    package body Context_Support is separate;

--| Memory control procedures.

    procedure Free_Temporary_Storage is
    begin
	Context_Support.Free_Temporary_Storage;
    end Free_Temporary_Storage;

    procedure Free is new Unchecked_Deallocation 
			     (Reference_Holder, Reference_Holder_Ptr);

    procedure Free_Holder_List is
	H : Reference_Holder_Ptr;
	T : Reference_Holder_Ptr;
    begin
	H := Reference_List;
	while H /= null loop
	    T := H.Next;
	    Free (H);
	    H := T;
	end loop;
	Reference_List := null;
    end Free_Holder_List;

--| Scan procedure bodies...

    procedure Scan_Any (The_Element : in Asis.Element; 
			The_Context : in Context) is separate;

    procedure Scan_Any_List (The_List : in Asis.Element_List; 
			     The_Context : in Context) is separate;

    procedure Scan_Argument_Association (The_Association : in Asis.Association; 
					 The_Context : in Context) is separate;

    procedure Scan_Argument_Association_List 
		 (The_List : in Asis.Argument_Association_List; 
		  The_Context : in Context) is separate;

    procedure Scan_Case_Statement_Alternative 
		 (The_Alternative : in Asis.Case_Statement_Alternative; 
		  The_Context : in Context) is separate;

    procedure Scan_Case_Statement_Alternative_List 
		 (The_List : in Asis.Case_Statement_Alternative_List; 
		  The_Context : in Context) is separate;

    procedure Scan_Choice (The_Choice : in Asis.Choice; 
			   The_Context : in Context) is separate;

    procedure Scan_Choice_List (The_List : in Asis.Choice_List; 
				The_Context : in Context) is separate;

    procedure Scan_Compilation_Unit (The_Unit : in Asis.Compilation_Unit; 
				     The_Context : in Context) is separate;

    procedure Scan_Component_Association 
		 (The_Association : in Asis.Component_Association; 
		  The_Context : in Context) is separate;

    procedure Scan_Component_Association_List 
		 (The_List : in Asis.Component_Association_List; 
		  The_Context : in Context) is separate;

    procedure Scan_Component_Clause (The_Clause : in Asis.Component_Clause; 
				     The_Context : in Context) is separate;

    procedure Scan_Component_Clause_List 
		 (The_List : in Asis.Component_Clause_List; 
		  The_Context : in Context) is separate;

    procedure Scan_Constraint (The_Constraint : in Asis.Constraint; 
			       The_Context : in Context) is separate;

    procedure Scan_Context_Clause_List (The_List : in Asis.Context_Clause_List; 
					The_Context : in Context) is separate;

    procedure Scan_Declaration (The_Declaration : in Asis.Declaration; 
				The_Context : in Context) is separate;

    procedure Scan_Declaration_List (The_List : in Asis.Declaration_List; 
				     The_Context : in Context) is separate;

    procedure Scan_Declarative_Item_List 
		 (The_List : in Asis.Declarative_Item_List; 
		  The_Context : in Context) is separate;

    procedure Scan_Declarative_Region_Part 
		 (The_Region : in Rgn.Region; 
		  The_Context : in Context) is separate;

    procedure Scan_Discrete_Range (The_Range : in Asis.Discrete_Range; 
				   The_Context : in Context) is separate;

    procedure Scan_Discrete_Range_List (The_List : in Asis.Discrete_Range_List; 
					The_Context : in Context) is separate;

    procedure Scan_Discriminant_Association 
		 (The_Association : in Asis.Discriminant_Association; 
		  The_Context : in Context) is separate;

    procedure Scan_Discriminant_Association_List 
		 (The_List : in Asis.Discriminant_Association_List; 
		  The_Context : in Context) is separate;

    procedure Scan_Entity_Name_Definition 
		 (The_Definition : in Asis.Entity_Name_Definition; 
		  The_Context : in Context) is separate;

    procedure Scan_Entity_Name_Definition_List 
		 (The_List : in Asis.Entity_Name_Definition_List; 
		  The_Context : in Context) is separate;

    procedure Scan_Exception_Handler (The_Handler : in Asis.Exception_Handler; 
				      The_Context : in Context) is separate;

    procedure Scan_Exception_Handler_List 
		 (The_List : in Asis.Exception_Handler_List; 
		  The_Context : in Context) is separate;

    procedure Scan_Expression (The_Expression : in Asis.Expression; 
			       The_Context : in Context) is separate;

    procedure Scan_Expression_List (The_List : in Asis.Expression_List; 
				    The_Context : in Context) is separate;

    procedure Scan_If_Statement_Arm (The_Arm : in Asis.If_Statement_Arm; 
				     The_Context : in Context) is separate;

    procedure Scan_If_Statement_Arm_List 
		 (The_List : in Asis.If_Statement_Arm_List; 
		  The_Context : in Context) is separate;

    procedure Scan_Null_Component (The_Component : in Asis.Record_Component; 
				   The_Context : in Context) is separate;

    procedure Scan_Parameter_Association (The_Association : in Asis.Association; 
					  The_Context : in Context) is separate;

    procedure Scan_Parameter_Association_List 
		 (The_List : in Asis.Association_List; 
		  The_Context : in Context) is separate;

    procedure Scan_Pragma (The_Pragma : in Asis.Pragma_Element; 
			   The_Context : in Context) is separate;

    procedure Scan_Pragma_List (The_List : in Asis.Pragma_Element_List; 
				The_Context : in Context) is separate;

    procedure Scan_Record_Component_List 
		 (The_List : in Asis.Record_Component_List; 
		  The_Context : in Context) is separate;

    procedure Scan_Representation_Clause 
		 (The_Clause : in Asis.Representation_Clause; 
		  The_Context : in Context) is separate;

    procedure Scan_Select_Alternative 
		 (The_Alternative : in Asis.Select_Alternative; 
		  The_Context : in Context) is separate;

    procedure Scan_Select_Statement_Arm (The_Arm : in Asis.Select_Statement_Arm; 
					 The_Context : in Context) is separate;

    procedure Scan_Select_Statement_Arm_List 
		 (The_List : in Asis.Select_Statement_Arm_List; 
		  The_Context : in Context) is separate;

    procedure Scan_Statement (The_Statement : in Asis.Statement; 
			      The_Context : in Context) is separate;

    procedure Scan_Statement_List (The_List : in Asis.Statement_List; 
				   The_Context : in Context) is separate;

    procedure Scan_Subtype_Indication 
		 (The_Indication : in Asis.Subtype_Indication; 
		  The_Context : in Context) is separate;

    procedure Scan_Type_Definition (The_Definition : in Asis.Type_Definition; 
				    The_Context : in Context) is separate;

    procedure Scan_Use_Clause (The_Clause : in Asis.Context_Clause; 
			       The_Context : in Context) is separate;

    procedure Scan_Variant (The_Variant : in Asis.Variant; 
			    The_Context : in Context) is separate;

    procedure Scan_Variant_List (The_List : in Asis.Variant_List; 
				 The_Context : in Context) is separate;

    procedure Scan_Variant_Part (The_Part : in Asis.Record_Component; 
				 The_Context : in Context) is separate;

    procedure Scan_With_Clause (The_Clause : in Asis.Context_Clause; 
				The_Context : in Context) is separate;

end Reference_Scan;