Skip to content

R
riscv-gcc-1
Commit 50b8a7b8 by Ed Schonberg Committed by Arnaud Charlet
Options

sem_ch10.adb: Create a limited view of an incomplete type... 

2007-08-14  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch10.adb: Create a limited view of an incomplete type, to make
	treatment of limited views uniform for all visible declarations in a
	limited_withed package.
	Set flag indicating that a subprogram body for a child unit has a
	generated spec.
	(Analyze_Compilation_Unit): If unit is a subprogram body that has no
	separate declaration, remove the unit name from visibility after
	compilation, so that environment is clean for subsequent compilations.
	(Install_Limited_Context_Clauses): Do not install a
	limited_private_with_clause unless the current unit is a body or a
	private child unit.
	(Analyze_Subunit, Install_Parents): Treat generic and non-generic units
	in the same fashion.
	(Install_Limited_Withed_Unit): Do not install a limited with clause if
	it applies to the declaration of the current package body.
	(Remove_Private_With_Clauses): If there is a regular with_clause for
	the unit, delete Private_With_Clause from context, to prevent improper
	hiding when processing subsequent nested packages and instantiations.

From-SVN: r127436
parent febb581c
Showing with 248 additions and 170 deletions
gcc/ada/sem_ch10.adb
...@@ -230,7 +230,7 @@ package body Sem_Ch10 is ...@@ -230,7 +230,7 @@ package body Sem_Ch10 is
procedure Analyze_Compilation_Unit (N : Node_Id) is procedure Analyze_Compilation_Unit (N : Node_Id) is
Unit_Node : constant Node_Id := Unit (N); Unit_Node : constant Node_Id := Unit (N);
Lib_Unit : Node_Id := Library_Unit (N); Lib_Unit : Node_Id := Library_Unit (N);
Spec_Id : Node_Id; Spec_Id : Entity_Id;
Main_Cunit : constant Node_Id := Cunit (Main_Unit); Main_Cunit : constant Node_Id := Cunit (Main_Unit);
Par_Spec_Name : Unit_Name_Type; Par_Spec_Name : Unit_Name_Type;
Unum : Unit_Number_Type; Unum : Unit_Number_Type;
...@@ -590,7 +590,7 @@ package body Sem_Ch10 is ...@@ -590,7 +590,7 @@ package body Sem_Ch10 is
P_Name : Entity_Id := P_Id; P_Name : Entity_Id := P_Id;
begin begin
Pref := Name (Parent (Defining_Entity (N))); Pref := Name (Parent (Defining_Entity (N)));
if Nkind (Pref) = N_Expanded_Name then if Nkind (Pref) = N_Expanded_Name then
...@@ -707,10 +707,10 @@ package body Sem_Ch10 is ...@@ -707,10 +707,10 @@ package body Sem_Ch10 is
-- If the subprogram body is a child unit, we must create a -- If the subprogram body is a child unit, we must create a
-- declaration for it, in order to properly load the parent(s). -- declaration for it, in order to properly load the parent(s).
-- After this, the original unit does not acts as a spec, because -- After this, the original unit does not acts as a spec, because
-- there is an explicit one. If this unit appears in a context -- there is an explicit one. If this unit appears in a context
-- clause, then an implicit with on the parent will be added when -- clause, then an implicit with on the parent will be added when
-- installing the context. If this is the main unit, there is no -- installing the context. If this is the main unit, there is no
-- Unit_Table entry for the declaration, (It has the unit number -- Unit_Table entry for the declaration (it has the unit number
-- of the main unit) and code generation is unaffected. -- of the main unit) and code generation is unaffected.
Unum := Get_Cunit_Unit_Number (N); Unum := Get_Cunit_Unit_Number (N);
...@@ -729,7 +729,10 @@ package body Sem_Ch10 is ...@@ -729,7 +729,10 @@ package body Sem_Ch10 is
-- Build subprogram declaration and attach parent unit to it -- Build subprogram declaration and attach parent unit to it
-- This subprogram declaration does not come from source, -- This subprogram declaration does not come from source,
-- Nevertheless the backend must generate debugging info for -- Nevertheless the backend must generate debugging info for
-- it, and this must be indicated explicitly. -- it, and this must be indicated explicitly. We also mark
-- the body entity as a child unit now, to prevent a
-- cascaded error if the spec entity cannot be entered
-- in its scope.
declare declare
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
...@@ -752,7 +755,12 @@ package body Sem_Ch10 is ...@@ -752,7 +755,12 @@ package body Sem_Ch10 is
Set_Library_Unit (N, Lib_Unit); Set_Library_Unit (N, Lib_Unit);
Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum)); Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum));
Semantics (Lib_Unit); Semantics (Lib_Unit);
-- Now that a separate declaration exists, the body
-- of the child unit does not act as spec any longer.
Set_Acts_As_Spec (N, False); Set_Acts_As_Spec (N, False);
Set_Is_Child_Unit (Defining_Entity (Unit_Node));
Set_Needs_Debug_Info (Defining_Entity (Unit (Lib_Unit))); Set_Needs_Debug_Info (Defining_Entity (Unit (Lib_Unit)));
Set_Comes_From_Source_Default (SCS); Set_Comes_From_Source_Default (SCS);
end; end;
...@@ -801,9 +809,9 @@ package body Sem_Ch10 is ...@@ -801,9 +809,9 @@ package body Sem_Ch10 is
end if; end if;
-- With the analysis done, install the context. Note that we can't -- With the analysis done, install the context. Note that we can't
-- install the context from the with clauses as we analyze them, -- install the context from the with clauses as we analyze them, because
-- because each with clause must be analyzed in a clean visibility -- each with clause must be analyzed in a clean visibility context, so
-- context, so we have to wait and install them all at once. -- we have to wait and install them all at once.
Install_Context (N); Install_Context (N);
...@@ -838,8 +846,8 @@ package body Sem_Ch10 is ...@@ -838,8 +846,8 @@ package body Sem_Ch10 is
end if; end if;
end if; end if;
-- The above call might have made Unit_Node an N_Subprogram_Body -- The above call might have made Unit_Node an N_Subprogram_Body from
-- from something else, so propagate any Acts_As_Spec flag. -- something else, so propagate any Acts_As_Spec flag.
if Nkind (Unit_Node) = N_Subprogram_Body if Nkind (Unit_Node) = N_Subprogram_Body
and then Acts_As_Spec (Unit_Node) and then Acts_As_Spec (Unit_Node)
...@@ -907,16 +915,23 @@ package body Sem_Ch10 is ...@@ -907,16 +915,23 @@ package body Sem_Ch10 is
end if; end if;
-- Remove unit from visibility, so that environment is clean for
-- the next compilation, which is either the main unit or some
-- other unit in the context.
if Nkind (Unit_Node) = N_Package_Declaration if Nkind (Unit_Node) = N_Package_Declaration
or else Nkind (Unit_Node) in N_Generic_Declaration or else Nkind (Unit_Node) in N_Generic_Declaration
or else Nkind (Unit_Node) = N_Package_Renaming_Declaration or else Nkind (Unit_Node) = N_Package_Renaming_Declaration
or else Nkind (Unit_Node) = N_Subprogram_Declaration or else Nkind (Unit_Node) = N_Subprogram_Declaration
or else
(Nkind (Unit_Node) = N_Subprogram_Body
and then Acts_As_Spec (Unit_Node))
then then
Remove_Unit_From_Visibility (Defining_Entity (Unit_Node)); Remove_Unit_From_Visibility (Defining_Entity (Unit_Node));
-- If the unit is an instantiation whose body will be elaborated -- If the unit is an instantiation whose body will be elaborated for
-- for inlining purposes, use the the proper entity of the instance. -- inlining purposes, use the the proper entity of the instance. The
-- The entity may be missing if the instantiation was illegal. -- entity may be missing if the instantiation was illegal.
elsif Nkind (Unit_Node) = N_Package_Instantiation elsif Nkind (Unit_Node) = N_Package_Instantiation
and then not Error_Posted (Unit_Node) and then not Error_Posted (Unit_Node)
...@@ -929,41 +944,41 @@ package body Sem_Ch10 is ...@@ -929,41 +944,41 @@ package body Sem_Ch10 is
or else (Nkind (Unit_Node) = N_Subprogram_Body or else (Nkind (Unit_Node) = N_Subprogram_Body
and then not Acts_As_Spec (Unit_Node)) and then not Acts_As_Spec (Unit_Node))
then then
-- Bodies that are not the main unit are compiled if they -- Bodies that are not the main unit are compiled if they are generic
-- are generic or contain generic or inlined units. Their -- or contain generic or inlined units. Their analysis brings in the
-- analysis brings in the context of the corresponding spec -- context of the corresponding spec (unit declaration) which must be
-- (unit declaration) which must be removed as well, to -- removed as well, to return the compilation environment to its
-- return the compilation environment to its proper state. -- proper state.
Remove_Context (Lib_Unit); Remove_Context (Lib_Unit);
Set_Is_Immediately_Visible (Defining_Entity (Unit (Lib_Unit)), False); Set_Is_Immediately_Visible (Defining_Entity (Unit (Lib_Unit)), False);
end if; end if;
-- Last step is to deinstall the context we just installed -- Last step is to deinstall the context we just installed as well as
-- as well as the unit just compiled. -- the unit just compiled.
Remove_Context (N); Remove_Context (N);
-- If this is the main unit and we are generating code, we must -- If this is the main unit and we are generating code, we must check
-- check that all generic units in the context have a body if they -- that all generic units in the context have a body if they need it,
-- need it, even if they have not been instantiated. In the absence -- even if they have not been instantiated. In the absence of .ali files
-- of .ali files for generic units, we must force the load of the body, -- for generic units, we must force the load of the body, just to
-- just to produce the proper error if the body is absent. We skip this -- produce the proper error if the body is absent. We skip this
-- verification if the main unit itself is generic. -- verification if the main unit itself is generic.
if Get_Cunit_Unit_Number (N) = Main_Unit if Get_Cunit_Unit_Number (N) = Main_Unit
and then Operating_Mode = Generate_Code and then Operating_Mode = Generate_Code
and then Expander_Active and then Expander_Active
then then
-- Check whether the source for the body of the unit must be -- Check whether the source for the body of the unit must be included
-- included in a standalone library. -- in a standalone library.
Check_Body_Needed_For_SAL (Cunit_Entity (Main_Unit)); Check_Body_Needed_For_SAL (Cunit_Entity (Main_Unit));
-- Indicate that the main unit is now analyzed, to catch possible -- Indicate that the main unit is now analyzed, to catch possible
-- circularities between it and generic bodies. Remove main unit -- circularities between it and generic bodies. Remove main unit from
-- from visibility. This might seem superfluous, but the main unit -- visibility. This might seem superfluous, but the main unit must
-- must not be visible in the generic body expansions that follow. -- not be visible in the generic body expansions that follow.
Set_Analyzed (N, True); Set_Analyzed (N, True);
Set_Is_Immediately_Visible (Cunit_Entity (Main_Unit), False); Set_Is_Immediately_Visible (Cunit_Entity (Main_Unit), False);
...@@ -1050,23 +1065,23 @@ package body Sem_Ch10 is ...@@ -1050,23 +1065,23 @@ package body Sem_Ch10 is
if Comes_From_Source (N) if Comes_From_Source (N)
and then and then
(Nkind (Unit (N)) = N_Package_Declaration or else (Nkind (Unit_Node) = N_Package_Declaration or else
Nkind (Unit (N)) = N_Generic_Package_Declaration or else Nkind (Unit_Node) = N_Generic_Package_Declaration or else
Nkind (Unit (N)) = N_Subprogram_Declaration or else Nkind (Unit_Node) = N_Subprogram_Declaration or else
Nkind (Unit (N)) = N_Generic_Subprogram_Declaration) Nkind (Unit_Node) = N_Generic_Subprogram_Declaration)
then then
declare declare
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
Unum : constant Unit_Number_Type := Get_Source_Unit (Loc); Unum : constant Unit_Number_Type := Get_Source_Unit (Loc);
begin begin
Spec_Id := Defining_Entity (Unit (N)); Spec_Id := Defining_Entity (Unit_Node);
Generate_Definition (Spec_Id); Generate_Definition (Spec_Id);
-- See if an elaboration entity is required for possible -- See if an elaboration entity is required for possible access
-- access before elaboration checking. Note that we must -- before elaboration checking. Note that we must allow for this
-- allow for this even if -gnatE is not set, since a client -- even if -gnatE is not set, since a client may be compiled in
-- may be compiled in -gnatE mode and reference the entity. -- -gnatE mode and reference the entity.
-- These entities are also used by the binder to prevent multiple -- These entities are also used by the binder to prevent multiple
-- attempts to execute the elaboration code for the library case -- attempts to execute the elaboration code for the library case
...@@ -1168,7 +1183,7 @@ package body Sem_Ch10 is ...@@ -1168,7 +1183,7 @@ package body Sem_Ch10 is
-- Push current compilation unit as scope, so that the test for -- Push current compilation unit as scope, so that the test for
-- being within an obsolescent unit will work correctly. -- being within an obsolescent unit will work correctly.
Push_Scope (Defining_Entity (Unit (N))); Push_Scope (Defining_Entity (Unit_Node));
-- Loop through context items to deal with with clauses -- Loop through context items to deal with with clauses
...@@ -1375,14 +1390,14 @@ package body Sem_Ch10 is ...@@ -1375,14 +1390,14 @@ package body Sem_Ch10 is
Unit_Name) Unit_Name)
then then
Error_Msg_Sloc := Sloc (It); Error_Msg_Sloc := Sloc (It);
Error_Msg_N
("simultaneous visibility of limited "
& "and unlimited views not allowed",
Item);
Error_Msg_NE Error_Msg_NE
("unlimited view visible through the" ("\unlimited view visible through "
& " context clause found #", & "context clause #",
Item, It); Item, It);
Error_Msg_N
("\simultaneous visibility of the limited"
& " and unlimited views not allowed"
, Item);
exit; exit;
elsif Nkind (Unit_Name) = N_Identifier then elsif Nkind (Unit_Name) = N_Identifier then
...@@ -1979,7 +1994,9 @@ package body Sem_Ch10 is ...@@ -1979,7 +1994,9 @@ package body Sem_Ch10 is
-- all the parents are bodies. Restore full visibility of their -- all the parents are bodies. Restore full visibility of their
-- private entities. -- private entities.
if Ekind (Scop) = E_Package then if Ekind (Scop) = E_Package
or else Ekind (Scop) = E_Generic_Package
then
Set_In_Package_Body (Scop); Set_In_Package_Body (Scop);
Install_Private_Declarations (Scop); Install_Private_Declarations (Scop);
end if; end if;
...@@ -2069,7 +2086,9 @@ package body Sem_Ch10 is ...@@ -2069,7 +2086,9 @@ package body Sem_Ch10 is
-- context includes another subunit of the same parent which in -- context includes another subunit of the same parent which in
-- turn includes a child unit in its context. -- turn includes a child unit in its context.
if Ekind (Par_Unit) = E_Package then if Ekind (Par_Unit) = E_Package
or else Ekind (Par_Unit) = E_Generic_Package
then
if not Is_Immediately_Visible (Par_Unit) if not Is_Immediately_Visible (Par_Unit)
or else (Present (First_Entity (Par_Unit)) or else (Present (First_Entity (Par_Unit))
and then not Is_Immediately_Visible and then not Is_Immediately_Visible
...@@ -2236,15 +2255,15 @@ package body Sem_Ch10 is ...@@ -2236,15 +2255,15 @@ package body Sem_Ch10 is
U := Unit (Library_Unit (N)); U := Unit (Library_Unit (N));
Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)); Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit));
-- Following checks are skipped for dummy packages (those supplied -- Following checks are skipped for dummy packages (those supplied for
-- for with's where no matching file could be found). Such packages -- with's where no matching file could be found). Such packages are
-- are identified by the Sloc value being set to No_Location -- identified by the Sloc value being set to No_Location
if Sloc (U) /= No_Location then if Sloc (U) /= No_Location then
-- Check restrictions, except that we skip the check if this -- Check restrictions, except that we skip the check if this is an
-- is an internal unit unless we are compiling the internal -- internal unit unless we are compiling the internal unit as the
-- unit as the main unit. We also skip this for dummy packages. -- main unit. We also skip this for dummy packages.
Check_Restriction_No_Dependence (Nam, N); Check_Restriction_No_Dependence (Nam, N);
...@@ -2266,10 +2285,10 @@ package body Sem_Ch10 is ...@@ -2266,10 +2285,10 @@ package body Sem_Ch10 is
Special_Exception_Package_Used := True; Special_Exception_Package_Used := True;
end if; end if;
-- Check for inappropriate with of internal implementation unit -- Check for inappropriate with of internal implementation unit if we
-- if we are currently compiling the main unit and the main unit -- are currently compiling the main unit and the main unit is itself
-- is itself not an internal unit. We do not issue this message -- not an internal unit. We do not issue this message for implicit
-- for implicit with's generated by the compiler itself. -- with's generated by the compiler itself.
if Implementation_Unit_Warnings if Implementation_Unit_Warnings
and then Current_Sem_Unit = Main_Unit and then Current_Sem_Unit = Main_Unit
...@@ -2306,11 +2325,11 @@ package body Sem_Ch10 is ...@@ -2306,11 +2325,11 @@ package body Sem_Ch10 is
if Unit_Kind in N_Generic_Declaration then if Unit_Kind in N_Generic_Declaration then
E_Name := Defining_Entity (U); E_Name := Defining_Entity (U);
-- Note: in the following test, Unit_Kind is the original Nkind, but -- Note: in the following test, Unit_Kind is the original Nkind, but in
-- in the case of an instantiation, semantic analysis above will -- the case of an instantiation, semantic analysis above will have
-- have replaced the unit by its instantiated version. If the instance -- replaced the unit by its instantiated version. If the instance body
-- body has been generated, the instance now denotes the body entity. -- has been generated, the instance now denotes the body entity. For
-- For visibility purposes we need the entity of its spec. -- visibility purposes we need the entity of its spec.
elsif (Unit_Kind = N_Package_Instantiation elsif (Unit_Kind = N_Package_Instantiation
or else Nkind (Original_Node (Unit (Library_Unit (N)))) = or else Nkind (Original_Node (Unit (Library_Unit (N)))) =
...@@ -2330,9 +2349,9 @@ package body Sem_Ch10 is ...@@ -2330,9 +2349,9 @@ package body Sem_Ch10 is
elsif Unit_Kind in N_Subprogram_Instantiation then elsif Unit_Kind in N_Subprogram_Instantiation then
-- Instantiation node is replaced with a wrapper package. -- Instantiation node is replaced with a wrapper package. Retrieve
-- Retrieve the visible subprogram created by the instance from -- the visible subprogram created by the instance from corresponding
-- the corresponding attribute of the wrapper. -- attribute of the wrapper.
E_Name := Related_Instance (Defining_Entity (U)); E_Name := Related_Instance (Defining_Entity (U));
...@@ -2469,8 +2488,8 @@ package body Sem_Ch10 is ...@@ -2469,8 +2488,8 @@ package body Sem_Ch10 is
elsif Nkind (Lib_Unit) = N_Subunit then elsif Nkind (Lib_Unit) = N_Subunit then
-- The parent is itself a body. The parent entity is to be found -- The parent is itself a body. The parent entity is to be found in
-- in the corresponding spec. -- the corresponding spec.
Sub_Parent := Library_Unit (N); Sub_Parent := Library_Unit (N);
Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent))); Curr_Unit := Defining_Entity (Unit (Library_Unit (Sub_Parent)));
...@@ -2519,9 +2538,9 @@ package body Sem_Ch10 is ...@@ -2519,9 +2538,9 @@ package body Sem_Ch10 is
Curr_Private : Boolean := Is_Private_Library_Unit (Curr_Unit); Curr_Private : Boolean := Is_Private_Library_Unit (Curr_Unit);
begin begin
-- If the child unit is a public child then locate -- If the child unit is a public child then locate the nearest
-- the nearest private ancestor; Child_Parent will -- private ancestor. Child_Parent will then be set to the
-- then be set to the parent of that ancestor. -- parent of that ancestor.
if not Is_Private_Library_Unit (Priv_Child) then if not Is_Private_Library_Unit (Priv_Child) then
while Present (Prv_Ancestor) while Present (Prv_Ancestor)
...@@ -2710,9 +2729,7 @@ package body Sem_Ch10 is ...@@ -2710,9 +2729,7 @@ package body Sem_Ch10 is
is is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
P : constant Node_Id := Parent_Spec (Child_Unit); P : constant Node_Id := Parent_Spec (Child_Unit);
P_Unit : Node_Id := Unit (P);
P_Unit : Node_Id := Unit (P);
P_Name : constant Entity_Id := Get_Parent_Entity (P_Unit); P_Name : constant Entity_Id := Get_Parent_Entity (P_Unit);
Withn : Node_Id; Withn : Node_Id;
...@@ -2720,8 +2737,7 @@ package body Sem_Ch10 is ...@@ -2720,8 +2737,7 @@ package body Sem_Ch10 is
-- Build prefix of child unit name. Recurse if needed -- Build prefix of child unit name. Recurse if needed
function Build_Unit_Name return Node_Id; function Build_Unit_Name return Node_Id;
-- If the unit is a child unit, build qualified name with all -- If the unit is a child unit, build qualified name with all ancestors
-- ancestors.
------------------------- -------------------------
-- Build_Ancestor_Name -- -- Build_Ancestor_Name --
...@@ -2775,9 +2791,9 @@ package body Sem_Ch10 is ...@@ -2775,9 +2791,9 @@ package body Sem_Ch10 is
-- Start of processing for Implicit_With_On_Parent -- Start of processing for Implicit_With_On_Parent
begin begin
-- The unit of the current compilation may be a package body -- The unit of the current compilation may be a package body that
-- that replaces an instance node. In this case we need the -- replaces an instance node. In this case we need the original instance
-- original instance node to construct the proper parent name. -- node to construct the proper parent name.
if Nkind (P_Unit) = N_Package_Body if Nkind (P_Unit) = N_Package_Body
and then Nkind (Original_Node (P_Unit)) = N_Package_Instantiation and then Nkind (Original_Node (P_Unit)) = N_Package_Instantiation
...@@ -2785,9 +2801,9 @@ package body Sem_Ch10 is ...@@ -2785,9 +2801,9 @@ package body Sem_Ch10 is
P_Unit := Original_Node (P_Unit); P_Unit := Original_Node (P_Unit);
end if; end if;
-- We add the implicit with if the child unit is the current unit -- We add the implicit with if the child unit is the current unit being
-- being compiled. If the current unit is a body, we do not want -- compiled. If the current unit is a body, we do not want to add an
-- to add an implicit_with a second time to the corresponding spec. -- implicit_with a second time to the corresponding spec.
if Nkind (Child_Unit) = N_Package_Declaration if Nkind (Child_Unit) = N_Package_Declaration
and then Child_Unit /= Unit (Cunit (Current_Sem_Unit)) and then Child_Unit /= Unit (Cunit (Current_Sem_Unit))
...@@ -2918,8 +2934,8 @@ package body Sem_Ch10 is ...@@ -2918,8 +2934,8 @@ package body Sem_Ch10 is
Decl_Node := Unit_Declaration_Node (Uname_Node); Decl_Node := Unit_Declaration_Node (Uname_Node);
-- If the unit is a subprogram instance, it appears nested -- If the unit is a subprogram instance, it appears nested within
-- within a package that carries the parent information. -- a package that carries the parent information.
if Is_Generic_Instance (Uname_Node) if Is_Generic_Instance (Uname_Node)
and then Ekind (Uname_Node) /= E_Package and then Ekind (Uname_Node) /= E_Package
...@@ -3213,8 +3229,8 @@ package body Sem_Ch10 is ...@@ -3213,8 +3229,8 @@ package body Sem_Ch10 is
("unlimited view visible through use clause ", W); ("unlimited view visible through use clause ", W);
return; return;
end if; end if;
end if; end if;
Next (Nam); Next (Nam);
end loop; end loop;
end if; end if;
...@@ -3264,7 +3280,6 @@ package body Sem_Ch10 is ...@@ -3264,7 +3280,6 @@ package body Sem_Ch10 is
-- unit to check if it is a descendant of named library unit. -- unit to check if it is a descendant of named library unit.
Curr_Parent := Parent (Item); Curr_Parent := Parent (Item);
while Present (Parent_Spec (Unit (Curr_Parent))) while Present (Parent_Spec (Unit (Curr_Parent)))
and then Curr_Parent /= Child_Parent and then Curr_Parent /= Child_Parent
loop loop
...@@ -3422,15 +3437,27 @@ package body Sem_Ch10 is ...@@ -3422,15 +3437,27 @@ package body Sem_Ch10 is
Check_Renamings (Parent_Spec (Unit (N)), Item); Check_Renamings (Parent_Spec (Unit (N)), Item);
end if; end if;
-- A unit may have a limited with on itself if it has a -- A unit may have a limited with on itself if it has a limited
-- limited with_clause on one of its child units. In that -- with_clause on one of its child units. In that case it is
-- case it is already being compiled and it makes no sense -- already being compiled and it makes no sense to install its
-- to install its limited view. -- limited view.
-- If the item is a limited_private_with_clause, install it if the
-- current unit is a body or if it is a private child. Otherwise
-- the private clause is installed before analyzing the private
-- part of the current unit.
if Library_Unit (Item) /= Cunit (Current_Sem_Unit) if Library_Unit (Item) /= Cunit (Current_Sem_Unit)
and then not Limited_View_Installed (Item) and then not Limited_View_Installed (Item)
then then
Install_Limited_Withed_Unit (Item); if not Private_Present (Item)
or else Private_Present (N)
or else Nkind (Unit (N)) = N_Package_Body
or else Nkind (Unit (N)) = N_Subprogram_Body
or else Nkind (Unit (N)) = N_Subunit
then
Install_Limited_Withed_Unit (Item);
end if;
end if; end if;
-- All items other than Limited_With clauses are ignored (they were -- All items other than Limited_With clauses are ignored (they were
...@@ -3475,7 +3502,8 @@ package body Sem_Ch10 is ...@@ -3475,7 +3502,8 @@ package body Sem_Ch10 is
-- This is usually the case when analyzing a body that -- This is usually the case when analyzing a body that
-- has regular with-clauses, when the spec has limited -- has regular with-clauses, when the spec has limited
-- ones. -- ones.
-- if the non-limited view is still incomplete, it is
-- If the non-limited view is still incomplete, it is
-- the dummy entry already created, and the declaration -- the dummy entry already created, and the declaration
-- cannot be reanalyzed. This is the case when installing -- cannot be reanalyzed. This is the case when installing
-- a parent unit that has limited with-clauses. -- a parent unit that has limited with-clauses.
...@@ -3536,12 +3564,12 @@ package body Sem_Ch10 is ...@@ -3536,12 +3564,12 @@ package body Sem_Ch10 is
Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit); Error_Msg_N ("parent unit cannot be a renaming", Lib_Unit);
raise Unrecoverable_Error; raise Unrecoverable_Error;
-- Verify that a child of an instance is itself an instance, or -- Verify that a child of an instance is itself an instance, or the
-- the renaming of one. Given that an instance that is a unit is -- renaming of one. Given that an instance that is a unit is replaced
-- replaced with a package declaration, check against the original -- with a package declaration, check against the original node. The
-- node. The parent may be currently being instantiated, in which -- parent may be currently being instantiated, in which case it appears
-- case it appears as a declaration, but the generic_parent is -- as a declaration, but the generic_parent is already established
-- already established indicating that we deal with an instance. -- indicating that we deal with an instance.
elsif Nkind (Original_Node (P)) = N_Package_Instantiation then elsif Nkind (Original_Node (P)) = N_Package_Instantiation then
...@@ -3572,13 +3600,13 @@ package body Sem_Ch10 is ...@@ -3572,13 +3600,13 @@ package body Sem_Ch10 is
Install_Limited_Context_Clauses (Parent_Spec (Lib_Unit)); Install_Limited_Context_Clauses (Parent_Spec (Lib_Unit));
Install_Siblings (P_Name, Parent (Lib_Unit)); Install_Siblings (P_Name, Parent (Lib_Unit));
-- The child unit is in the declarative region of the parent. The -- The child unit is in the declarative region of the parent. The parent
-- parent must therefore appear in the scope stack and be visible, -- must therefore appear in the scope stack and be visible, as when
-- as when compiling the corresponding body. If the child unit is -- compiling the corresponding body. If the child unit is private or it
-- private or it is a package body, private declarations must be -- is a package body, private declarations must be accessible as well.
-- accessible as well. Use declarations in the parent must also -- Use declarations in the parent must also be installed. Finally, other
-- be installed. Finally, other child units of the same parent that -- child units of the same parent that are in the context are
-- are in the context are immediately visible. -- immediately visible.
-- Find entity for compilation unit, and set its private descendant -- Find entity for compilation unit, and set its private descendant
-- status as needed. -- status as needed.
...@@ -3602,8 +3630,8 @@ package body Sem_Ch10 is ...@@ -3602,8 +3630,8 @@ package body Sem_Ch10 is
Install_Visible_Declarations (P_Name); Install_Visible_Declarations (P_Name);
Set_Use (Visible_Declarations (P_Spec)); Set_Use (Visible_Declarations (P_Spec));
-- If the parent is a generic unit, its formal part may contain -- If the parent is a generic unit, its formal part may contain formal
-- formal packages and use clauses for them. -- packages and use clauses for them.
if Ekind (P_Name) = E_Generic_Package then if Ekind (P_Name) = E_Generic_Package then
Set_Use (Generic_Formal_Declarations (Parent (P_Spec))); Set_Use (Generic_Formal_Declarations (Parent (P_Spec)));
...@@ -3662,9 +3690,9 @@ package body Sem_Ch10 is ...@@ -3662,9 +3690,9 @@ package body Sem_Ch10 is
Id : Entity_Id; Id : Entity_Id;
Prev : Entity_Id; Prev : Entity_Id;
begin begin
-- Iterate over explicit with clauses, and check whether the -- Iterate over explicit with clauses, and check whether the scope of
-- scope of each entity is an ancestor of the current unit, in -- each entity is an ancestor of the current unit, in which case it is
-- which case it is immediately visible. -- immediately visible.
Item := First (Context_Items (N)); Item := First (Context_Items (N));
while Present (Item) loop while Present (Item) loop
...@@ -3717,11 +3745,11 @@ package body Sem_Ch10 is ...@@ -3717,11 +3745,11 @@ package body Sem_Ch10 is
end; end;
end if; end if;
-- The With_Clause may be on a grand-child or one of its -- The With_Clause may be on a grand-child or one of its further
-- further descendants, which makes a child immediately visible. -- descendants, which makes a child immediately visible. Examine
-- Examine ancestry to determine whether such a child exists. -- ancestry to determine whether such a child exists. For example,
-- For example, if current unit is A.C, and with_clause is on -- if current unit is A.C, and with_clause is on A.X.Y.Z, then X
-- A.X.Y.Z, then X is immediately visible. -- is immediately visible.
elsif Is_Child_Unit (Id) then elsif Is_Child_Unit (Id) then
declare declare
...@@ -3816,14 +3844,14 @@ package body Sem_Ch10 is ...@@ -3816,14 +3844,14 @@ package body Sem_Ch10 is
if Kind = N_Package_Declaration then if Kind = N_Package_Declaration then
Error_Msg_N Error_Msg_N
("simultaneous visibility of the limited and" & ("simultaneous visibility of the limited and " &
" unlimited views not allowed", N); "unlimited views not allowed", N);
Error_Msg_Sloc := Sloc (Item); Error_Msg_Sloc := Sloc (Item);
Error_Msg_NE Error_Msg_NE
("\unlimited view of & visible through the" & ("\\ unlimited view of & visible through the " &
" context clause found #", N, P); "context clause #", N, P);
Error_Msg_Sloc := Sloc (Decl); Error_Msg_Sloc := Sloc (Decl);
Error_Msg_NE ("\and the renaming found #", N, P); Error_Msg_NE ("\\ and the renaming #", N, P);
end if; end if;
return True; return True;
...@@ -3890,9 +3918,14 @@ package body Sem_Ch10 is ...@@ -3890,9 +3918,14 @@ package body Sem_Ch10 is
-- This unusual case will happen when a unit has a limited_with clause -- This unusual case will happen when a unit has a limited_with clause
-- on one of its children. The compilation of the child forces the -- on one of its children. The compilation of the child forces the
-- load of the parent which tries to install the limited view of the -- load of the parent which tries to install the limited view of the
-- child again. -- child again. Installing the limited view must also be disabled
-- when compiling the body of the child unit.
if P = Cunit_Entity (Current_Sem_Unit) then if P = Cunit_Entity (Current_Sem_Unit)
or else
(Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body
and then P = Main_Unit_Entity)
then
return; return;
end if; end if;
...@@ -4013,7 +4046,7 @@ package body Sem_Ch10 is ...@@ -4013,7 +4046,7 @@ package body Sem_Ch10 is
-- by the shadow ones. -- by the shadow ones.
-- This code must be kept synchronized with the code that replaces the -- This code must be kept synchronized with the code that replaces the
-- the shadow entities by the real entities (see body of Remove_Limited -- shadow entities by the real entities (see body of Remove_Limited
-- With_Clause); otherwise the contents of the homonym chains are not -- With_Clause); otherwise the contents of the homonym chains are not
-- consistent. -- consistent.
...@@ -4035,7 +4068,8 @@ package body Sem_Ch10 is ...@@ -4035,7 +4068,8 @@ package body Sem_Ch10 is
-- Replace the real entities by the shadow entities of the limited -- Replace the real entities by the shadow entities of the limited
-- view. The first element of the limited view is a header that is -- view. The first element of the limited view is a header that is
-- used to reference the first shadow entity in the private part -- used to reference the first shadow entity in the private part
-- of the package. -- of the package. Successive elements are the limited views of the
-- type (including regular incomplete types) declared in the package.
Lim_Header := Limited_View (P); Lim_Header := Limited_View (P);
...@@ -4055,18 +4089,10 @@ package body Sem_Ch10 is ...@@ -4055,18 +4089,10 @@ package body Sem_Ch10 is
begin begin
Prev := Current_Entity (Lim_Typ); Prev := Current_Entity (Lim_Typ);
E := Prev;
-- Handle incomplete types -- Replace E in the homonyms list, so that the limited
-- view becomes available.
if Ekind (Prev) = E_Incomplete_Type
and then Present (Full_View (Prev))
then
E := Full_View (Prev);
else
E := Prev;
end if;
-- Replace E in the homonyms list
if E = Non_Limited_View (Lim_Typ) then if E = Non_Limited_View (Lim_Typ) then
Set_Homonym (Lim_Typ, Homonym (Prev)); Set_Homonym (Lim_Typ, Homonym (Prev));
...@@ -4075,21 +4101,21 @@ package body Sem_Ch10 is ...@@ -4075,21 +4101,21 @@ package body Sem_Ch10 is
else else
loop loop
E := Homonym (Prev); E := Homonym (Prev);
pragma Assert (Present (E));
-- Handle incomplete types -- E may have been removed when installing a
-- previous limited_with_clause.
if Ekind (E) = E_Incomplete_Type then exit when No (E);
E := Full_View (E);
end if;
exit when E = Non_Limited_View (Lim_Typ); exit when E = Non_Limited_View (Lim_Typ);
Prev := Homonym (Prev); Prev := Homonym (Prev);
end loop; end loop;
Set_Homonym (Lim_Typ, Homonym (Homonym (Prev))); if Present (E) then
Set_Homonym (Prev, Lim_Typ); Set_Homonym (Lim_Typ, Homonym (Homonym (Prev)));
Set_Homonym (Prev, Lim_Typ);
end if;
end if; end if;
end; end;
...@@ -4282,7 +4308,7 @@ package body Sem_Ch10 is ...@@ -4282,7 +4308,7 @@ package body Sem_Ch10 is
begin begin
U2 := Homonym (Uname); U2 := Homonym (Uname);
while Present (U2) while Present (U2)
and U2 /= Standard_Standard and then U2 /= Standard_Standard
loop loop
P2 := Scope (U2); P2 := Scope (U2);
Decl2 := Unit_Declaration_Node (P2); Decl2 := Unit_Declaration_Node (P2);
...@@ -4297,7 +4323,7 @@ package body Sem_Ch10 is ...@@ -4297,7 +4323,7 @@ package body Sem_Ch10 is
Error_Msg_N ("illegal with_clause", With_Clause); Error_Msg_N ("illegal with_clause", With_Clause);
Error_Msg_N Error_Msg_N
("\child unit has visible homograph" & ("\child unit has visible homograph" &
" ('R'M 8.3(26), 10.1.1(19))", " (RM 8.3(26), 10.1.1(19))",
With_Clause); With_Clause);
exit; exit;
...@@ -4322,7 +4348,7 @@ package body Sem_Ch10 is ...@@ -4322,7 +4348,7 @@ package body Sem_Ch10 is
Error_Msg_N ("illegal with_clause", Prev_Clause); Error_Msg_N ("illegal with_clause", Prev_Clause);
Error_Msg_N Error_Msg_N
("\child unit has visible homograph" & ("\child unit has visible homograph" &
" ('R'M 8.3(26), 10.1.1(19))", " (RM 8.3(26), 10.1.1(19))",
Prev_Clause); Prev_Clause);
exit; exit;
end; end;
...@@ -4357,15 +4383,14 @@ package body Sem_Ch10 is ...@@ -4357,15 +4383,14 @@ package body Sem_Ch10 is
-- Load_Needed_Body -- -- Load_Needed_Body --
----------------------- -----------------------
-- N is a generic unit named in a with clause, or else it is -- N is a generic unit named in a with clause, or else it is a unit that
-- a unit that contains a generic unit or an inlined function. -- contains a generic unit or an inlined function. In order to perform an
-- In order to perform an instantiation, the body of the unit -- instantiation, the body of the unit must be present. If the unit itself
-- must be present. If the unit itself is generic, we assume -- is generic, we assume that an instantiation follows, and load & analyze
-- that an instantiation follows, and load and analyze the body -- the body unconditionally. This forces analysis of the spec as well.
-- unconditionally. This forces analysis of the spec as well.
-- If the unit is not generic, but contains a generic unit, it -- If the unit is not generic, but contains a generic unit, it is loaded on
-- is loaded on demand, at the point of instantiation (see ch12). -- demand, at the point of instantiation (see ch12).
procedure Load_Needed_Body (N : Node_Id; OK : out Boolean) is procedure Load_Needed_Body (N : Node_Id; OK : out Boolean) is
Body_Name : Unit_Name_Type; Body_Name : Unit_Name_Type;
...@@ -4569,16 +4594,17 @@ package body Sem_Ch10 is ...@@ -4569,16 +4594,17 @@ package body Sem_Ch10 is
-- For each library_package_declaration in the environment, there -- For each library_package_declaration in the environment, there
-- is an implicit declaration of a *limited view* of that library -- is an implicit declaration of a *limited view* of that library
-- package. The limited view of a package contains: -- package. The limited view of a package contains:
--
-- * For each nested package_declaration, a declaration of the -- * For each nested package_declaration, a declaration of the
-- limited view of that package, with the same defining- -- limited view of that package, with the same defining-
-- program-unit name. -- program-unit name.
--
-- * For each type_declaration in the visible part, an incomplete -- * For each type_declaration in the visible part, an incomplete
-- type-declaration with the same defining_identifier, whose -- type-declaration with the same defining_identifier, whose
-- completion is the type_declaration. If the type_declaration -- completion is the type_declaration. If the type_declaration
-- is tagged, then the incomplete_type_declaration is tagged -- is tagged, then the incomplete_type_declaration is tagged
-- incomplete. -- incomplete.
-- The partial view is tagged if the declaration has the -- The partial view is tagged if the declaration has the
-- explicit keyword, or else if it is a type extension, both -- explicit keyword, or else if it is a type extension, both
-- of which can be ascertained syntactically. -- of which can be ascertained syntactically.
...@@ -4622,7 +4648,9 @@ package body Sem_Ch10 is ...@@ -4622,7 +4648,9 @@ package body Sem_Ch10 is
Set_Non_Limited_View (Lim_Typ, Comp_Typ); Set_Non_Limited_View (Lim_Typ, Comp_Typ);
elsif Nkind (Decl) = N_Private_Type_Declaration then elsif Nkind (Decl) = N_Private_Type_Declaration
or else Nkind (Decl) = N_Incomplete_Type_Declaration
then
Comp_Typ := Defining_Identifier (Decl); Comp_Typ := Defining_Identifier (Decl);
if not Analyzed_Unit then if not Analyzed_Unit then
...@@ -4716,8 +4744,8 @@ package body Sem_Ch10 is ...@@ -4716,8 +4744,8 @@ package body Sem_Ch10 is
begin begin
pragma Assert (Limited_Present (N)); pragma Assert (Limited_Present (N));
-- A library_item mentioned in a limited_with_clause shall be -- A library_item mentioned in a limited_with_clause shall
-- a package_declaration, not a subprogram_declaration, -- be a package_declaration, not a subprogram_declaration,
-- generic_declaration, generic_instantiation, or -- generic_declaration, generic_instantiation, or
-- package_renaming_declaration -- package_renaming_declaration
...@@ -4779,8 +4807,8 @@ package body Sem_Ch10 is ...@@ -4779,8 +4807,8 @@ package body Sem_Ch10 is
Set_Is_Internal (Lim_Header); Set_Is_Internal (Lim_Header);
Set_Limited_View (P, Lim_Header); Set_Limited_View (P, Lim_Header);
-- Create the auxiliary chain. All the shadow entities are appended -- Create the auxiliary chain. All the shadow entities are appended to
-- to the list of entities of the limited-view header -- the list of entities of the limited-view header
Build_Chain Build_Chain
(Scope => P, (Scope => P,
...@@ -4815,9 +4843,9 @@ package body Sem_Ch10 is ...@@ -4815,9 +4843,9 @@ package body Sem_Ch10 is
procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is
function Entity_Needs_Body (E : Entity_Id) return Boolean; function Entity_Needs_Body (E : Entity_Id) return Boolean;
-- Determine whether use of entity E might require the presence -- Determine whether use of entity E might require the presence of its
-- of its body. For a package this requires a recursive traversal -- body. For a package this requires a recursive traversal of all nested
-- of all nested declarations. -- declarations.
--------------------------- ---------------------------
-- Entity_Needed_For_SAL -- -- Entity_Needed_For_SAL --
...@@ -4960,8 +4988,8 @@ package body Sem_Ch10 is ...@@ -4960,8 +4988,8 @@ package body Sem_Ch10 is
Item := First (Context_Items (N)); Item := First (Context_Items (N));
while Present (Item) loop while Present (Item) loop
-- We are interested only in with clauses which got installed -- We are interested only in with clauses which got installed on
-- on entry, as indicated by their Context_Installed flag set -- entry, as indicated by their Context_Installed flag set
if Nkind (Item) = N_With_Clause if Nkind (Item) = N_With_Clause
and then Limited_Present (Item) and then Limited_Present (Item)
...@@ -5107,9 +5135,10 @@ package body Sem_Ch10 is ...@@ -5107,9 +5135,10 @@ package body Sem_Ch10 is
loop loop
Prev := Homonym (Prev); Prev := Homonym (Prev);
end loop; end loop;
pragma Assert (Present (Prev));
Set_Homonym (Prev, E); if Present (Prev) then
Set_Homonym (Prev, E);
end if;
end if; end if;
-- We must also set the next homonym entity of the real entity -- We must also set the next homonym entity of the real entity
...@@ -5188,23 +5217,72 @@ package body Sem_Ch10 is ...@@ -5188,23 +5217,72 @@ package body Sem_Ch10 is
procedure Remove_Private_With_Clauses (Comp_Unit : Node_Id) is procedure Remove_Private_With_Clauses (Comp_Unit : Node_Id) is
Item : Node_Id; Item : Node_Id;
function In_Regular_With_Clause (E : Entity_Id) return Boolean;
-- Check whether a given unit appears in a regular with_clause.
-- Used to determine whether a private_with_clause, implicit or
-- explicit, should be ignored.
----------------------------
-- In_Regular_With_Clause --
----------------------------
function In_Regular_With_Clause (E : Entity_Id) return Boolean
is
Item : Node_Id;
begin
Item := First (Context_Items (Comp_Unit));
while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then Entity (Name (Item)) = E
and then not Private_Present (Item)
then
return True;
end if;
Next (Item);
end loop;
return False;
end In_Regular_With_Clause;
-- Start of processing for Remove_Private_With_Clauses
begin begin
Item := First (Context_Items (Comp_Unit)); Item := First (Context_Items (Comp_Unit));
while Present (Item) loop while Present (Item) loop
if Nkind (Item) = N_With_Clause if Nkind (Item) = N_With_Clause
and then Private_Present (Item) and then Private_Present (Item)
then then
if Limited_Present (Item) then
-- If private_with_clause is redundant, remove it from
-- context, as a small optimization to subsequent handling
-- of private_with clauses in other nested packages..
if In_Regular_With_Clause (Entity (Name (Item))) then
declare
Nxt : constant Node_Id := Next (Item);
begin
Remove (Item);
Item := Nxt;
end;
elsif Limited_Present (Item) then
if not Limited_View_Installed (Item) then if not Limited_View_Installed (Item) then
Remove_Limited_With_Clause (Item); Remove_Limited_With_Clause (Item);
end if; end if;
Next (Item);
else else
Remove_Unit_From_Visibility (Entity (Name (Item))); Remove_Unit_From_Visibility (Entity (Name (Item)));
Set_Context_Installed (Item, False); Set_Context_Installed (Item, False);
Next (Item);
end if; end if;
end if;
Next (Item); else
Next (Item);
end if;
end loop; end loop;
end Remove_Private_With_Clauses; end Remove_Private_With_Clauses;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment