-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
package body Sem is
+ Debug_Unit_Walk : Boolean renames Debug_Flag_Dot_WW;
+ -- Controls debugging printouts for Walk_Library_Items
+
Outer_Generic_Scope : Entity_Id := Empty;
- -- Global reference to the outer scope that is generic. In a non
- -- generic context, it is empty. At the moment, it is only used
- -- for avoiding freezing of external references in generics.
+ -- Global reference to the outer scope that is generic. In a non-generic
+ -- context, it is empty. At the moment, it is only used for avoiding
+ -- freezing of external references in generics.
Comp_Unit_List : Elist_Id := No_Elist;
-- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes
-- No_Elist, because it's too early to call New_Elmt_List; we will set it
-- to New_Elmt_List on first use.
- Ignore_Comp_Units : Boolean := False;
- -- If True, we suppress appending compilation units onto the
- -- Comp_Unit_List.
+ generic
+ with procedure Action (Withed_Unit : Node_Id);
+ procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean);
+ -- Walk all the with clauses of CU, and call Action for the with'ed unit.
+ -- Ignore limited withs, unless Include_Limited is True. CU must be an
+ -- N_Compilation_Unit.
+
+ generic
+ with procedure Action (Withed_Unit : Node_Id);
+ procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean);
+ -- Same as Walk_Withs_Immediate, but also include with clauses on subunits
+ -- of this unit, since they count as dependences on their parent library
+ -- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit.
+
+ procedure Write_Unit_Info
+ (Unit_Num : Unit_Number_Type;
+ Item : Node_Id;
+ Prefix : String := "";
+ Withs : Boolean := False);
+ -- Print out debugging information about the unit. Prefix precedes the rest
+ -- of the printout. If Withs is True, we print out units with'ed by this
+ -- unit (not counting limited withs).
-------------
-- Analyze --
when N_Block_Statement =>
Analyze_Block_Statement (N);
+ when N_Case_Expression =>
+ Analyze_Case_Expression (N);
+
when N_Case_Statement =>
Analyze_Case_Statement (N);
when N_Explicit_Dereference =>
Analyze_Explicit_Dereference (N);
+ when N_Expression_With_Actions =>
+ Analyze_Expression_With_Actions (N);
+
when N_Extended_Return_Statement =>
Analyze_Extended_Return_Statement (N);
Analyze_Formal_Object_Declaration (N);
when N_Formal_Package_Declaration =>
- Analyze_Formal_Package (N);
+ Analyze_Formal_Package_Declaration (N);
when N_Formal_Subprogram_Declaration =>
- Analyze_Formal_Subprogram (N);
+ Analyze_Formal_Subprogram_Declaration (N);
when N_Formal_Type_Declaration =>
Analyze_Formal_Type_Declaration (N);
Analyze_Free_Statement (N);
when N_Freeze_Entity =>
- null; -- no semantic processing required
+ Analyze_Freeze_Entity (N);
when N_Full_Type_Declaration =>
- Analyze_Type_Declaration (N);
+ Analyze_Full_Type_Declaration (N);
when N_Function_Call =>
Analyze_Function_Call (N);
when N_Integer_Literal =>
Analyze_Integer_Literal (N);
+ when N_Iterator_Specification =>
+ Analyze_Iterator_Specification (N);
+
when N_Itype_Reference =>
Analyze_Itype_Reference (N);
when N_Parameter_Association =>
Analyze_Parameter_Association (N);
+ when N_Parameterized_Expression =>
+ Analyze_Parameterized_Expression (N);
+
when N_Pragma =>
Analyze_Pragma (N);
Analyze_Protected_Definition (N);
when N_Protected_Type_Declaration =>
- Analyze_Protected_Type (N);
+ Analyze_Protected_Type_Declaration (N);
when N_Qualified_Expression =>
Analyze_Qualified_Expression (N);
+ when N_Quantified_Expression =>
+ Analyze_Quantified_Expression (N);
+
when N_Raise_Statement =>
Analyze_Raise_Statement (N);
Analyze_Selective_Accept (N);
when N_Single_Protected_Declaration =>
- Analyze_Single_Protected (N);
+ Analyze_Single_Protected_Declaration (N);
when N_Single_Task_Declaration =>
- Analyze_Single_Task (N);
+ Analyze_Single_Task_Declaration (N);
when N_Slice =>
Analyze_Slice (N);
Analyze_Task_Definition (N);
when N_Task_Type_Declaration =>
- Analyze_Task_Type (N);
+ Analyze_Task_Type_Declaration (N);
when N_Terminate_Alternative =>
Analyze_Terminate_Alternative (N);
when N_With_Clause =>
Analyze_With_Clause (N);
- -- A call to analyze the Empty node is an error, but most likely
- -- it is an error caused by an attempt to analyze a malformed
- -- piece of tree caused by some other error, so if there have
- -- been any other errors, we just ignore it, otherwise it is
- -- a real internal error which we complain about.
+ -- A call to analyze the Empty node is an error, but most likely it
+ -- is an error caused by an attempt to analyze a malformed piece of
+ -- tree caused by some other error, so if there have been any other
+ -- errors, we just ignore it, otherwise it is a real internal error
+ -- which we complain about.
- -- We must also consider the case of call to a runtime function
- -- that is not available in the configurable runtime.
+ -- We must also consider the case of call to a runtime function that
+ -- is not available in the configurable runtime.
when N_Empty =>
pragma Assert (Serious_Errors_Detected /= 0
when N_Push_Pop_xxx_Label =>
null;
+ -- SCIL nodes don't need analysis because they are decorated when
+ -- they are built. They are added to the tree by Insert_Actions and
+ -- the call to analyze them is generated when the full list is
+ -- analyzed.
+
+ when
+ N_SCIL_Dispatch_Table_Tag_Init |
+ N_SCIL_Dispatching_Call |
+ N_SCIL_Membership_Test =>
+ null;
+
-- For the remaining node types, we generate compiler abort, because
-- these nodes are always analyzed within the Sem_Chn routines and
-- there should never be a case of making a call to the main Analyze
N_Access_Function_Definition |
N_Access_Procedure_Definition |
N_Access_To_Object_Definition |
+ N_Aspect_Specification |
+ N_Case_Expression_Alternative |
N_Case_Statement_Alternative |
N_Compilation_Unit_Aux |
N_Component_Association |
return;
end if;
- -- Now search the global entity suppress table for a matching entry
+ -- Now search the global entity suppress table for a matching entry.
-- We also search this in reverse order so that if there are multiple
-- pragmas for the same entity, the last one applies.
Node := First (L);
Insert_List_After (N, L);
- -- Now just analyze from the original first node until we get to
- -- the successor of the original insertion point (which may be
- -- Empty if the insertion point was at the end of the list). Note
- -- that this properly handles the case where any of the analyze
- -- calls result in the insertion of nodes after the analyzed
- -- node (possibly calling this routine recursively).
+ -- Now just analyze from the original first node until we get to the
+ -- successor of the original insertion point (which may be Empty if
+ -- the insertion point was at the end of the list). Note that this
+ -- properly handles the case where any of the analyze calls result in
+ -- the insertion of nodes after the analyzed node (possibly calling
+ -- this routine recursively).
while Node /= After loop
Analyze (Node);
begin
if Is_Non_Empty_List (L) then
- -- Capture the Node_Id of the first list node to be inserted.
- -- This will still be the first node after the insert operation,
- -- since Insert_List_After does not modify the Node_Id values.
+ -- Capture the Node_Id of the first list node to be inserted. This
+ -- will still be the first node after the insert operation, since
+ -- Insert_List_After does not modify the Node_Id values.
Node := First (L);
Insert_List_Before (N, L);
Ptr : Suppress_Stack_Entry_Ptr;
begin
- -- First search the local entity suppress stack, we search this from the
- -- top of the stack down, so that we get the innermost entry that
- -- applies to this case if there are nested entries.
+ -- First search the local entity suppress stack. We search this from the
+ -- top of the stack down so that we get the innermost entry that applies
+ -- to this case if there are nested entries.
Ptr := Local_Suppress_Stack_Top;
while Ptr /= null loop
Ptr := Ptr.Prev;
end loop;
- -- Now search the global entity suppress table for a matching entry
+ -- Now search the global entity suppress table for a matching entry.
-- We also search this from the top down so that if there are multiple
-- pragmas for the same entity, the last one applies (not clear what
-- or whether the RM specifies this handling, but it seems reasonable).
procedure Semantics (Comp_Unit : Node_Id) is
-- The following locations save the corresponding global flags and
- -- variables so that they can be restored on completion. This is
- -- needed so that calls to Rtsfind start with the proper default
- -- values for these variables, and also that such calls do not
- -- disturb the settings for units being analyzed at a higher level.
+ -- variables so that they can be restored on completion. This is needed
+ -- so that calls to Rtsfind start with the proper default values for
+ -- these variables, and also that such calls do not disturb the settings
+ -- for units being analyzed at a higher level.
S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
S_Full_Analysis : constant Boolean := Full_Analysis;
-- context, is compiled with expansion disabled.
Save_Config_Switches : Config_Switches_Type;
- -- Variable used to save values of config switches while we analyze
- -- the new unit, to be restored on exit for proper recursive behavior.
+ -- Variable used to save values of config switches while we analyze the
+ -- new unit, to be restored on exit for proper recursive behavior.
procedure Do_Analyze;
- -- Procedure to analyze the compilation unit. This is called more
- -- than once when the high level optimizer is activated.
+ -- Procedure to analyze the compilation unit. This is called more than
+ -- once when the high level optimizer is activated.
----------------
-- Do_Analyze --
Restore_Scope_Stack;
end Do_Analyze;
+ Already_Analyzed : constant Boolean := Analyzed (Comp_Unit);
+
-- Start of processing for Semantics
begin
+ if Debug_Unit_Walk then
+ if Already_Analyzed then
+ Write_Str ("(done)");
+ end if;
+
+ Write_Unit_Info
+ (Get_Cunit_Unit_Number (Comp_Unit),
+ Unit (Comp_Unit),
+ Prefix => "--> ");
+ Indent;
+ end if;
+
Compiler_State := Analyzing;
Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit);
-- Cleaner might be to do the kludge at the point of excluding the
-- pragma (do not exclude for renamings ???)
- GNAT_Mode :=
- GNAT_Mode
- or else Is_Predefined_File_Name
- (Unit_File_Name (Current_Sem_Unit),
- Renamings_Included => False);
+ if Is_Predefined_File_Name
+ (Unit_File_Name (Current_Sem_Unit), Renamings_Included => False)
+ then
+ GNAT_Mode := True;
+ end if;
if Generic_Main then
Expander_Mode_Save_And_Set (False);
end if;
-- Do analysis, and then append the compilation unit onto the
- -- Comp_Unit_List, if appropriate. This is done after analysis, so if
- -- this unit depends on some others, they have already been
+ -- Comp_Unit_List, if appropriate. This is done after analysis,
+ -- so if this unit depends on some others, they have already been
-- appended. We ignore bodies, except for the main unit itself, and
- -- everything those bodies depend upon.
+ -- for subprogram bodies that act as specs. We have also to guard
+ -- against ill-formed subunits that have an improper context.
- if Ignore_Comp_Units then
- Do_Analyze;
- pragma Assert (Ignore_Comp_Units); -- still
+ Do_Analyze;
- elsif Nkind (Unit (Comp_Unit)) in N_Proper_Body
+ if Present (Comp_Unit)
+ and then Nkind (Unit (Comp_Unit)) in N_Proper_Body
+ and then (Nkind (Unit (Comp_Unit)) /= N_Subprogram_Body
+ or else not Acts_As_Spec (Comp_Unit))
and then not In_Extended_Main_Source_Unit (Comp_Unit)
then
- Ignore_Comp_Units := True;
- Do_Analyze;
- pragma Assert (Ignore_Comp_Units);
- Ignore_Comp_Units := False;
+ null;
else
- Do_Analyze;
- -- pragma Assert (not Ignore_Comp_Units);
- -- The above assertion is *almost* true. It fails only when a
- -- subunit with's its parent procedure body, which has no explicit
- -- spec.
+ -- Initialize if first time
- if No (Comp_Unit_List) then -- Initialize if first time
+ if No (Comp_Unit_List) then
Comp_Unit_List := New_Elmt_List;
end if;
- if not Ignore_Comp_Units then -- See above commented-out Assert
- Append_Elmt (Comp_Unit, Comp_Unit_List);
- end if;
- -- Ignore all units after main unit
+ Append_Elmt (Comp_Unit, Comp_Unit_List);
- if Comp_Unit = Cunit (Main_Unit) then
- Ignore_Comp_Units := True;
+ if Debug_Unit_Walk then
+ Write_Str ("Appending ");
+ Write_Unit_Info
+ (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit));
end if;
end if;
end if;
Restore_Opt_Config_Switches (Save_Config_Switches);
Expander_Mode_Restore;
+
+ if Debug_Unit_Walk then
+ Outdent;
+
+ if Already_Analyzed then
+ Write_Str ("(done)");
+ end if;
+
+ Write_Unit_Info
+ (Get_Cunit_Unit_Number (Comp_Unit),
+ Unit (Comp_Unit),
+ Prefix => "<-- ");
+ end if;
end Semantics;
------------------------
------------------------
procedure Walk_Library_Items is
- Enable_Output : constant Boolean := False;
- -- Set to True to print out the items as we go (for debugging)
+ type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean;
+ pragma Pack (Unit_Number_Set);
+
+ Main_CU : constant Node_Id := Cunit (Main_Unit);
+
+ Seen, Done : Unit_Number_Set := (others => False);
+ -- Seen (X) is True after we have seen unit X in the walk. This is used
+ -- to prevent processing the same unit more than once. Done (X) is True
+ -- after we have fully processed X, and is used only for debugging
+ -- printouts and assertions.
+
+ Do_Main : Boolean := False;
+ -- Flag to delay processing the main body until after all other units.
+ -- This is needed because the spec of the main unit may appear in the
+ -- context of some other unit. We do not want this to force processing
+ -- of the main body before all other units have been processed.
+ --
+ -- Another circularity pattern occurs when the main unit is a child unit
+ -- and the body of an ancestor has a with-clause of the main unit or on
+ -- one of its children. In both cases the body in question has a with-
+ -- clause on the main unit, and must be excluded from the traversal. In
+ -- some convoluted cases this may lead to a CodePeer error because the
+ -- spec of a subprogram declared in an instance within the parent will
+ -- not be seen in the main unit.
+
+ function Depends_On_Main (CU : Node_Id) return Boolean;
+ -- The body of a unit that is withed by the spec of the main unit may in
+ -- turn have a with_clause on that spec. In that case do not traverse
+ -- the body, to prevent loops. It can also happen that the main body has
+ -- a with_clause on a child, which of course has an implicit with on its
+ -- parent. It's OK to traverse the child body if the main spec has been
+ -- processed, otherwise we also have a circularity to avoid.
procedure Do_Action (CU : Node_Id; Item : Node_Id);
-- Calls Action, with some validity checks
+ procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id);
+ -- Calls Do_Action, first on the units with'ed by this one, then on
+ -- this unit. If it's an instance body, do the spec first. If it is
+ -- an instance spec, do the body last.
+
+ procedure Do_Withed_Unit (Withed_Unit : Node_Id);
+ -- Apply Do_Unit_And_Dependents to a unit in a context clause.
+
+ procedure Process_Bodies_In_Context (Comp : Node_Id);
+ -- The main unit and its spec may depend on bodies that contain generics
+ -- that are instantiated in them. Iterate through the corresponding
+ -- contexts before processing main (spec/body) itself, to process bodies
+ -- that may be present, together with their context. The spec of main
+ -- is processed wherever it appears in the list of units, while the body
+ -- is processed as the last unit in the list.
+
+ ---------------------
+ -- Depends_On_Main --
+ ---------------------
+
+ function Depends_On_Main (CU : Node_Id) return Boolean is
+ CL : Node_Id;
+ MCU : constant Node_Id := Unit (Main_CU);
+
+ begin
+ CL := First (Context_Items (CU));
+
+ -- Problem does not arise with main subprograms
+
+ if
+ not Nkind_In (MCU, N_Package_Body, N_Package_Declaration)
+ then
+ return False;
+ end if;
+
+ while Present (CL) loop
+ if Nkind (CL) = N_With_Clause
+ and then Library_Unit (CL) = Main_CU
+ and then not Done (Get_Cunit_Unit_Number (Library_Unit (CL)))
+ then
+ return True;
+ end if;
+
+ Next (CL);
+ end loop;
+
+ return False;
+ end Depends_On_Main;
+
---------------
-- Do_Action --
---------------
-- This calls Action at the end. All the preceding code is just
-- assertions and debugging output.
+ pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit);
+
case Nkind (Item) is
- when N_Generic_Subprogram_Declaration |
- N_Generic_Package_Declaration |
- N_Package_Declaration |
- N_Subprogram_Declaration |
- N_Subprogram_Renaming_Declaration |
- N_Package_Renaming_Declaration |
- N_Generic_Function_Renaming_Declaration |
- N_Generic_Package_Renaming_Declaration |
- N_Generic_Procedure_Renaming_Declaration =>
- null; -- Specs are OK
-
- when N_Package_Body | N_Subprogram_Body =>
- -- A body must be the main unit
-
- pragma Assert (CU = Cunit (Main_Unit));
+ when N_Generic_Subprogram_Declaration |
+ N_Generic_Package_Declaration |
+ N_Package_Declaration |
+ N_Subprogram_Declaration |
+ N_Subprogram_Renaming_Declaration |
+ N_Package_Renaming_Declaration |
+ N_Generic_Function_Renaming_Declaration |
+ N_Generic_Package_Renaming_Declaration |
+ N_Generic_Procedure_Renaming_Declaration =>
+
+ -- Specs are OK
+
null;
- -- All other cases cannot happen
+ when N_Package_Body =>
+
+ -- Package bodies are processed separately if the main unit
+ -- depends on them.
+
+ null;
+
+ when N_Subprogram_Body =>
+
+ -- A subprogram body must be the main unit
+
+ pragma Assert (Acts_As_Spec (CU)
+ or else CU = Cunit (Main_Unit));
+ null;
+
+ when N_Function_Instantiation |
+ N_Procedure_Instantiation |
+ N_Package_Instantiation =>
+
+ -- Can only happen if some generic body (needed for gnat2scil
+ -- traversal, but not by GNAT) is not available, ignore.
- when N_Function_Instantiation |
- N_Procedure_Instantiation |
- N_Package_Instantiation =>
- pragma Assert (False, "instantiation");
null;
+ -- All other cases cannot happen
+
when N_Subunit =>
pragma Assert (False, "subunit");
null;
if Present (CU) then
pragma Assert (Item /= Stand.Standard_Package_Node);
+ pragma Assert (Item = Unit (CU));
+
+ declare
+ Unit_Num : constant Unit_Number_Type :=
+ Get_Cunit_Unit_Number (CU);
+
+ procedure Assert_Done (Withed_Unit : Node_Id);
+ -- Assert Withed_Unit is already Done, unless it's a body. It
+ -- might seem strange for a with_clause to refer to a body, but
+ -- this happens in the case of a generic instantiation, which
+ -- gets transformed into the instance body (and the instance
+ -- spec is also created). With clauses pointing to the
+ -- instantiation end up pointing to the instance body.
+
+ -----------------
+ -- Assert_Done --
+ -----------------
+
+ procedure Assert_Done (Withed_Unit : Node_Id) is
+ begin
+ if not Done (Get_Cunit_Unit_Number (Withed_Unit)) then
+ if not Nkind_In
+ (Unit (Withed_Unit),
+ N_Generic_Package_Declaration,
+ N_Package_Body,
+ N_Package_Renaming_Declaration,
+ N_Subprogram_Body)
+ then
+ Write_Unit_Name
+ (Unit_Name (Get_Cunit_Unit_Number (Withed_Unit)));
+ Write_Str (" not yet walked!");
+
+ if Get_Cunit_Unit_Number (Withed_Unit) = Unit_Num then
+ Write_Str (" (self-ref)");
+ end if;
+
+ Write_Eol;
+
+ pragma Assert (False);
+ end if;
+ end if;
+ end Assert_Done;
- if Enable_Output then
- Write_Unit_Name (Unit_Name (Get_Cunit_Unit_Number (CU)));
- Write_Str (", Unit_Number = ");
- Write_Int (Int (Get_Cunit_Unit_Number (CU)));
- Write_Str (", ");
- Write_Str (Node_Kind'Image (Nkind (Item)));
+ procedure Assert_Withed_Units_Done is
+ new Walk_Withs (Assert_Done);
- if Item /= Original_Node (Item) then
- Write_Str (", orig = ");
- Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
+ begin
+ if Debug_Unit_Walk then
+ Write_Unit_Info (Unit_Num, Item, Withs => True);
end if;
- Write_Eol;
- end if;
+ -- Main unit should come last, except in the case where we
+ -- skipped System_Aux_Id, in which case we missed the things it
+ -- depends on, and in the case of parent bodies if present.
+
+ pragma Assert
+ (not Done (Main_Unit)
+ or else Present (System_Aux_Id)
+ or else Nkind (Item) = N_Package_Body);
+
+ -- We shouldn't do the same thing twice
+
+ pragma Assert (not Done (Unit_Num));
+
+ -- Everything we depend upon should already be done
+
+ pragma Debug
+ (Assert_Withed_Units_Done (CU, Include_Limited => False));
+ end;
else
- -- Must be Standard
+ -- Must be Standard, which has no entry in the units table
pragma Assert (Item = Stand.Standard_Package_Node);
- if Enable_Output then
+ if Debug_Unit_Walk then
Write_Line ("Standard");
end if;
end if;
Action (Item);
end Do_Action;
+ --------------------
+ -- Do_Withed_Unit --
+ --------------------
+
+ procedure Do_Withed_Unit (Withed_Unit : Node_Id) is
+ begin
+ Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit));
+
+ -- If the unit in the with_clause is a generic instance, the clause
+ -- now denotes the instance body. Traverse the corresponding spec
+ -- because there may be no other dependence that will force the
+ -- traversal of its own context.
+
+ if Nkind (Unit (Withed_Unit)) = N_Package_Body
+ and then Is_Generic_Instance
+ (Defining_Entity (Unit (Library_Unit (Withed_Unit))))
+ then
+ Do_Withed_Unit (Library_Unit (Withed_Unit));
+ end if;
+ end Do_Withed_Unit;
+
+ ----------------------------
+ -- Do_Unit_And_Dependents --
+ ----------------------------
+
+ procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is
+ Unit_Num : constant Unit_Number_Type := Get_Cunit_Unit_Number (CU);
+ Child : Node_Id;
+ Body_U : Unit_Number_Type;
+ Parent_CU : Node_Id;
+
+ procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
+
+ begin
+ if not Seen (Unit_Num) then
+
+ -- Process the with clauses
+
+ Do_Withed_Units (CU, Include_Limited => False);
+
+ -- Process the unit if it is a spec or the the main unit, if it
+ -- has no previous spec or we have done all other units.
+
+ if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body)
+ or else Acts_As_Spec (CU)
+ then
+ if CU = Cunit (Main_Unit)
+ and then not Do_Main
+ then
+ Seen (Unit_Num) := False;
+
+ else
+ Seen (Unit_Num) := True;
+
+ if CU = Library_Unit (Main_CU) then
+ Process_Bodies_In_Context (CU);
+
+ -- If main is a child unit, examine parent unit contexts
+ -- to see if they include instantiated units. Also, if
+ -- the parent itself is an instance, process its body
+ -- because it may contain subprograms that are called
+ -- in the main unit.
+
+ if Is_Child_Unit (Cunit_Entity (Main_Unit)) then
+ Child := Cunit_Entity (Main_Unit);
+ while Is_Child_Unit (Child) loop
+ Parent_CU :=
+ Cunit
+ (Get_Cunit_Entity_Unit_Number (Scope (Child)));
+ Process_Bodies_In_Context (Parent_CU);
+
+ if Nkind (Unit (Parent_CU)) = N_Package_Body
+ and then
+ Nkind (Original_Node (Unit (Parent_CU)))
+ = N_Package_Instantiation
+ and then
+ not Seen (Get_Cunit_Unit_Number (Parent_CU))
+ then
+ Body_U := Get_Cunit_Unit_Number (Parent_CU);
+ Seen (Body_U) := True;
+ Do_Action (Parent_CU, Unit (Parent_CU));
+ Done (Body_U) := True;
+ end if;
+
+ Child := Scope (Child);
+ end loop;
+ end if;
+ end if;
+
+ Do_Action (CU, Item);
+ Done (Unit_Num) := True;
+ end if;
+ end if;
+ end if;
+ end Do_Unit_And_Dependents;
+
+ -------------------------------
+ -- Process_Bodies_In_Context --
+ -------------------------------
+
+ procedure Process_Bodies_In_Context (Comp : Node_Id) is
+ Body_CU : Node_Id;
+ Body_U : Unit_Number_Type;
+ Clause : Node_Id;
+ Spec : Node_Id;
+
+ procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
+
+ -- Start of processing for Process_Bodies_In_Context
+
+ begin
+ Clause := First (Context_Items (Comp));
+ while Present (Clause) loop
+ if Nkind (Clause) = N_With_Clause then
+ Spec := Library_Unit (Clause);
+ Body_CU := Library_Unit (Spec);
+
+ -- If we are processing the spec of the main unit, load bodies
+ -- only if the with_clause indicates that it forced the loading
+ -- of the body for a generic instantiation. Note that bodies of
+ -- parents that are instances have been loaded already.
+
+ if Present (Body_CU)
+ and then Body_CU /= Cunit (Main_Unit)
+ and then Nkind (Unit (Body_CU)) /= N_Subprogram_Body
+ and then (Nkind (Unit (Comp)) /= N_Package_Declaration
+ or else Present (Withed_Body (Clause)))
+ then
+ Body_U := Get_Cunit_Unit_Number (Body_CU);
+
+ if not Seen (Body_U)
+ and then not Depends_On_Main (Body_CU)
+ then
+ Seen (Body_U) := True;
+ Do_Withed_Units (Body_CU, Include_Limited => False);
+ Do_Action (Body_CU, Unit (Body_CU));
+ Done (Body_U) := True;
+ end if;
+ end if;
+ end if;
+
+ Next (Clause);
+ end loop;
+ end Process_Bodies_In_Context;
+
-- Local Declarations
- Cur : Elmt_Id := First_Elmt (Comp_Unit_List);
+ Cur : Elmt_Id;
-- Start of processing for Walk_Library_Items
begin
- if Enable_Output then
+ if Debug_Unit_Walk then
Write_Line ("Walk_Library_Items:");
Indent;
end if;
Do_Action (Empty, Standard_Package_Node);
+ -- First place the context of all instance bodies on the corresponding
+ -- spec, because it may be needed to analyze the code at the place of
+ -- the instantiation.
+
+ Cur := First_Elmt (Comp_Unit_List);
while Present (Cur) loop
declare
CU : constant Node_Id := Node (Cur);
N : constant Node_Id := Unit (CU);
begin
+ if Nkind (N) = N_Package_Body
+ and then Is_Generic_Instance (Defining_Entity (N))
+ then
+ Append_List
+ (Context_Items (CU), Context_Items (Library_Unit (CU)));
+ end if;
+
+ Next_Elmt (Cur);
+ end;
+ end loop;
+
+ -- Now traverse compilation units (specs) in order
+
+ Cur := First_Elmt (Comp_Unit_List);
+ while Present (Cur) loop
+ declare
+ CU : constant Node_Id := Node (Cur);
+ N : constant Node_Id := Unit (CU);
+ Par : Entity_Id;
+
+ begin
pragma Assert (Nkind (CU) = N_Compilation_Unit);
case Nkind (N) is
- -- If it's a body, then ignore it, unless it's an instance (in
- -- which case we do the spec), or it's the main unit (in which
- -- case we do it). Note that it could be both.
-
- when N_Package_Body | N_Subprogram_Body =>
- declare
- Entity : Node_Id := N;
+ -- If it is a subprogram body, process it if it has no
+ -- separate spec.
+
+ -- If it's a package body, ignore it, unless it is a body
+ -- created for an instance that is the main unit. In the case
+ -- of subprograms, the body is the wrapper package. In case of
+ -- a package, the original file carries the body, and the spec
+ -- appears as a later entry in the units list.
+
+ -- Otherwise bodies appear in the list only because of inlining
+ -- or instantiations, and they are processed only if relevant.
+ -- The flag Withed_Body on a context clause indicates that a
+ -- unit contains an instantiation that may be needed later,
+ -- and therefore the body that contains the generic body (and
+ -- its context) must be traversed immediately after the
+ -- corresponding spec (see Do_Unit_And_Dependents).
+
+ -- The main unit itself is processed separately after all other
+ -- specs, and relevant bodies are examined in Process_Main.
+
+ when N_Subprogram_Body =>
+ if Acts_As_Spec (N) then
+ Do_Unit_And_Dependents (CU, N);
+ end if;
- begin
- if Nkind (N) = N_Subprogram_Body then
- Entity := Specification (Entity);
- end if;
+ when N_Package_Body =>
+ if CU = Main_CU
+ and then Nkind (Original_Node (Unit (Main_CU))) in
+ N_Generic_Instantiation
+ and then Present (Library_Unit (Main_CU))
+ then
+ Do_Unit_And_Dependents
+ (Library_Unit (Main_CU),
+ Unit (Library_Unit (Main_CU)));
+ end if;
- Entity := Defining_Unit_Name (Entity);
+ -- It's a spec, process it, and the units it depends on,
+ -- unless it is a descendent of the main unit. This can
+ -- happen when the body of a parent depends on some other
+ -- descendent.
- if Nkind (Entity) not in N_Entity then
+ when others =>
+ Par := Scope (Defining_Entity (Unit (CU)));
+
+ if Is_Child_Unit (Defining_Entity (Unit (CU))) then
+ while Present (Par)
+ and then Par /= Standard_Standard
+ and then Par /= Cunit_Entity (Main_Unit)
+ loop
+ Par := Scope (Par);
+ end loop;
+ end if;
- -- Must be N_Defining_Program_Unit_Name
+ if Par /= Cunit_Entity (Main_Unit) then
+ Do_Unit_And_Dependents (CU, N);
+ end if;
+ end case;
+ end;
- Entity := Defining_Identifier (Entity);
- end if;
+ Next_Elmt (Cur);
+ end loop;
- if Is_Generic_Instance (Entity) then
- Do_Action (CU, Unit (Library_Unit (CU)));
- end if;
- end;
+ -- Now process package bodies on which main depends, followed by bodies
+ -- of parents, if present, and finally main itself.
+
+ if not Done (Main_Unit) then
+ Do_Main := True;
+
+ Process_Main : declare
+ Parent_CU : Node_Id;
+ Body_CU : Node_Id;
+ Body_U : Unit_Number_Type;
+ Child : Entity_Id;
+
+ function Is_Subunit_Of_Main (U : Node_Id) return Boolean;
+ -- If the main unit has subunits, their context may include
+ -- bodies that are needed in the body of main. We must examine
+ -- the context of the subunits, which are otherwise not made
+ -- explicit in the main unit.
+
+ ------------------------
+ -- Is_Subunit_Of_Main --
+ ------------------------
+
+ function Is_Subunit_Of_Main (U : Node_Id) return Boolean is
+ Lib : Node_Id;
+ begin
+ if No (U) then
+ return False;
+ else
+ Lib := Library_Unit (U);
+ return Nkind (Unit (U)) = N_Subunit
+ and then
+ (Lib = Cunit (Main_Unit)
+ or else Is_Subunit_Of_Main (Lib));
+ end if;
+ end Is_Subunit_Of_Main;
- if CU = Cunit (Main_Unit) then
+ -- Start of processing for Process_Main
- -- Must come last
+ begin
+ Process_Bodies_In_Context (Main_CU);
- pragma Assert (No (Next_Elmt (Cur)));
+ for Unit_Num in Done'Range loop
+ if Is_Subunit_Of_Main (Cunit (Unit_Num)) then
+ Process_Bodies_In_Context (Cunit (Unit_Num));
+ end if;
+ end loop;
- Do_Action (CU, N);
+ -- If the main unit is a child unit, parent bodies may be present
+ -- because they export instances or inlined subprograms. Check for
+ -- presence of these, which are not present in context clauses.
+ -- Note that if the parents are instances, their bodies have been
+ -- processed before the main spec, because they may be needed
+ -- therein, so the following loop only affects non-instances.
+
+ if Is_Child_Unit (Cunit_Entity (Main_Unit)) then
+ Child := Cunit_Entity (Main_Unit);
+ while Is_Child_Unit (Child) loop
+ Parent_CU :=
+ Cunit (Get_Cunit_Entity_Unit_Number (Scope (Child)));
+ Body_CU := Library_Unit (Parent_CU);
+
+ if Present (Body_CU)
+ and then not Seen (Get_Cunit_Unit_Number (Body_CU))
+ and then not Depends_On_Main (Body_CU)
+ then
+ Body_U := Get_Cunit_Unit_Number (Body_CU);
+ Seen (Body_U) := True;
+ Do_Action (Body_CU, Unit (Body_CU));
+ Done (Body_U) := True;
end if;
- -- It's a spec, so just do it
+ Child := Scope (Child);
+ end loop;
+ end if;
- when others =>
- Do_Action (CU, N);
- end case;
- end;
+ Do_Action (Main_CU, Unit (Main_CU));
+ Done (Main_Unit) := True;
+ end Process_Main;
+ end if;
- Next_Elmt (Cur);
- end loop;
+ if Debug_Unit_Walk then
+ if Done /= (Done'Range => True) then
+ Write_Eol;
+ Write_Line ("Ignored units:");
- if Enable_Output then
+ Indent;
+
+ for Unit_Num in Done'Range loop
+ if not Done (Unit_Num) then
+ Write_Unit_Info
+ (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True);
+ end if;
+ end loop;
+
+ Outdent;
+ end if;
+ end if;
+
+ pragma Assert (Done (Main_Unit));
+
+ if Debug_Unit_Walk then
Outdent;
Write_Line ("end Walk_Library_Items.");
end if;
end Walk_Library_Items;
+ ----------------
+ -- Walk_Withs --
+ ----------------
+
+ procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean) is
+ pragma Assert (Nkind (CU) = N_Compilation_Unit);
+ pragma Assert (Nkind (Unit (CU)) /= N_Subunit);
+
+ procedure Walk_Immediate is new Walk_Withs_Immediate (Action);
+
+ begin
+ -- First walk the withs immediately on the library item
+
+ Walk_Immediate (CU, Include_Limited);
+
+ -- For a body, we must also check for any subunits which belong to it
+ -- and which have context clauses of their own, since these with'ed
+ -- units are part of its own dependencies.
+
+ if Nkind (Unit (CU)) in N_Unit_Body then
+ for S in Main_Unit .. Last_Unit loop
+
+ -- We are only interested in subunits. For preproc. data and def.
+ -- files, Cunit is Empty, so we need to test that first.
+
+ if Cunit (S) /= Empty
+ and then Nkind (Unit (Cunit (S))) = N_Subunit
+ then
+ declare
+ Pnode : Node_Id;
+
+ begin
+ Pnode := Library_Unit (Cunit (S));
+
+ -- In -gnatc mode, the errors in the subunits will not have
+ -- been recorded, but the analysis of the subunit may have
+ -- failed, so just quit.
+
+ if No (Pnode) then
+ exit;
+ end if;
+
+ -- Find ultimate parent of the subunit
+
+ while Nkind (Unit (Pnode)) = N_Subunit loop
+ Pnode := Library_Unit (Pnode);
+ end loop;
+
+ -- See if it belongs to current unit, and if so, include its
+ -- with_clauses. Do not process main unit prematurely.
+
+ if Pnode = CU and then CU /= Cunit (Main_Unit) then
+ Walk_Immediate (Cunit (S), Include_Limited);
+ end if;
+ end;
+ end if;
+ end loop;
+ end if;
+ end Walk_Withs;
+
+ --------------------------
+ -- Walk_Withs_Immediate --
+ --------------------------
+
+ procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean) is
+ pragma Assert (Nkind (CU) = N_Compilation_Unit);
+
+ Context_Item : Node_Id;
+ Lib_Unit : Node_Id;
+ Body_CU : Node_Id;
+
+ begin
+ Context_Item := First (Context_Items (CU));
+ while Present (Context_Item) loop
+ if Nkind (Context_Item) = N_With_Clause
+ and then (Include_Limited
+ or else not Limited_Present (Context_Item))
+ then
+ Lib_Unit := Library_Unit (Context_Item);
+ Action (Lib_Unit);
+
+ -- If the context item indicates that a package body is needed
+ -- because of an instantiation in CU, traverse the body now, even
+ -- if CU is not related to the main unit. If the generic itself
+ -- appears in a package body, the context item is this body, and
+ -- it already appears in the traversal order, so we only need to
+ -- examine the case of a context item being a package declaration.
+
+ if Present (Withed_Body (Context_Item))
+ and then Nkind (Unit (Lib_Unit)) = N_Package_Declaration
+ and then Present (Corresponding_Body (Unit (Lib_Unit)))
+ then
+ Body_CU :=
+ Parent
+ (Unit_Declaration_Node
+ (Corresponding_Body (Unit (Lib_Unit))));
+
+ -- A body may have an implicit with on its own spec, in which
+ -- case we must ignore this context item to prevent looping.
+
+ if Unit (CU) /= Unit (Body_CU) then
+ Action (Body_CU);
+ end if;
+ end if;
+ end if;
+
+ Context_Item := Next (Context_Item);
+ end loop;
+ end Walk_Withs_Immediate;
+
+ ---------------------
+ -- Write_Unit_Info --
+ ---------------------
+
+ procedure Write_Unit_Info
+ (Unit_Num : Unit_Number_Type;
+ Item : Node_Id;
+ Prefix : String := "";
+ Withs : Boolean := False)
+ is
+ begin
+ Write_Str (Prefix);
+ Write_Unit_Name (Unit_Name (Unit_Num));
+ Write_Str (", unit ");
+ Write_Int (Int (Unit_Num));
+ Write_Str (", ");
+ Write_Int (Int (Item));
+ Write_Str ("=");
+ Write_Str (Node_Kind'Image (Nkind (Item)));
+
+ if Item /= Original_Node (Item) then
+ Write_Str (", orig = ");
+ Write_Int (Int (Original_Node (Item)));
+ Write_Str ("=");
+ Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
+ end if;
+
+ Write_Eol;
+
+ -- Skip the rest if we're not supposed to print the withs
+
+ if not Withs then
+ return;
+ end if;
+
+ declare
+ Context_Item : Node_Id;
+
+ begin
+ Context_Item := First (Context_Items (Cunit (Unit_Num)));
+ while Present (Context_Item)
+ and then (Nkind (Context_Item) /= N_With_Clause
+ or else Limited_Present (Context_Item))
+ loop
+ Context_Item := Next (Context_Item);
+ end loop;
+
+ if Present (Context_Item) then
+ Indent;
+ Write_Line ("withs:");
+ Indent;
+
+ while Present (Context_Item) loop
+ if Nkind (Context_Item) = N_With_Clause
+ and then not Limited_Present (Context_Item)
+ then
+ pragma Assert (Present (Library_Unit (Context_Item)));
+ Write_Unit_Name
+ (Unit_Name
+ (Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
+
+ if Implicit_With (Context_Item) then
+ Write_Str (" -- implicit");
+ end if;
+
+ Write_Eol;
+ end if;
+
+ Context_Item := Next (Context_Item);
+ end loop;
+
+ Outdent;
+ Write_Line ("end withs");
+ Outdent;
+ end if;
+ end;
+ end Write_Unit_Info;
+
end Sem;
OSDN Git Service
