Skip to content

R
riscv-gcc-1
Commit 743c8beb by Ed Schonberg Committed by Arnaud Charlet
Options

sem_ch10.ads, [...] (Check_Redundant_Withs, [...]): If the context of a body… 

sem_ch10.ads, [...] (Check_Redundant_Withs, [...]): If the context of a body includes a use clause for P.Q then a with_clause for P...

2006-10-31  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch10.ads, sem_ch10.adb (Check_Redundant_Withs,
	Process_Body_Clauses): If the context of a body includes a use clause
	for P.Q then a with_clause for P in the same body is not redundant,
	even if the spec also has a with_clause on P.
	Add missing continuation mark to error msg
	(Build_Limited_Views): A limited view of a type is tagged if its
	declaration includes a record extension.
	(Analyze_Proper_Body): Set Corresponding_Stub field in N_Subunit
	node, even if the subunit has errors. This avoids malfunction by
	Lib.Check_Same_Extended_Unit in the presence of syntax errors.
	(Analyze_Compilation_Unit): Add circuit to make sure we get proper
	generation of obsolescent messages for with statements (cannot do
	this too early, or we cannot implement avoiding the messages in the
	case of obsolescent units withing obsolescent units).
	(Install_Siblings): If the with_clause is on a remote descendant of
	an ancestor of the current compilation unit, find whether there is
	a sibling child unit that is immediately visible.
	(Remove_Private_With_Clauses): New procedure, invoked after completing
	the analysis of the private part of a nested package, to remove from
	visibility the private with_clauses of the enclosing package
	declaration.
	(Analyze_With_Clause): Remove Check_Obsolescent call, this checking is
	now centralized in Generate_Reference.
	(Install_Limited_Context_Clauses): Remove superfluous error
	message associated with unlimited view visible through use
	and renamings. In addition, at the point in which the error
	is reported, we add the backslash to the text of the error
	to ensure that it is reported as a single error message.
	Use new // insertion for some continuation messages
	(Expand_Limited_With_Clause): Use copy of name rather than name itself,
	to create implicit with_clause for parent unit mentioned in original
	limited_with_clause.
	(Install_Limited_With_Unit): Set entity of parent identifiers if the
	unit is a child unit. For ASIS queries.
	(Analyze_Subunit): If the subunit appears within a child unit, make all
	ancestor child units directly visible again.

From-SVN: r118287
parent f6cf2af4
Showing with 339 additions and 90 deletions
gcc/ada/sem_ch10.adb
...@@ -45,6 +45,7 @@ with Output; use Output; ...@@ -45,6 +45,7 @@ with Output; use Output;
with Restrict; use Restrict; with Restrict; use Restrict;
with Rtsfind; use Rtsfind; with Rtsfind; use Rtsfind;
with Sem; use Sem; with Sem; use Sem;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6; with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7; with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8; with Sem_Ch8; use Sem_Ch8;
...@@ -316,10 +317,35 @@ package body Sem_Ch10 is ...@@ -316,10 +317,35 @@ package body Sem_Ch10 is
if Nkind (Cont_Item) = N_Use_Package_Clause if Nkind (Cont_Item) = N_Use_Package_Clause
and then not Used and then not Used
then then
-- Search through use clauses
Use_Item := First (Names (Cont_Item)); Use_Item := First (Names (Cont_Item));
while Present (Use_Item) and then not Used loop while Present (Use_Item) and then not Used loop
-- Case of a direct use of the one we are looking for
if Entity (Use_Item) = Nam_Ent then if Entity (Use_Item) = Nam_Ent then
Used := True; Used := True;
-- Handle nested case, as in "with P; use P.Q.R"
else
declare
UE : Node_Id;
begin
-- Loop through prefixes looking for match
UE := Use_Item;
while Nkind (UE) = N_Expanded_Name loop
if Entity (Prefix (UE)) = Nam_Ent then
Used := True;
exit;
end if;
UE := Prefix (UE);
end loop;
end;
end if; end if;
Next (Use_Item); Next (Use_Item);
...@@ -812,7 +838,6 @@ package body Sem_Ch10 is ...@@ -812,7 +838,6 @@ package body Sem_Ch10 is
if Present (Pragmas_After (Aux_Decls_Node (N))) then if Present (Pragmas_After (Aux_Decls_Node (N))) then
declare declare
Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N))); Prag_Node : Node_Id := First (Pragmas_After (Aux_Decls_Node (N)));
begin begin
while Present (Prag_Node) loop while Present (Prag_Node) loop
Analyze (Prag_Node); Analyze (Prag_Node);
...@@ -930,11 +955,14 @@ package body Sem_Ch10 is ...@@ -930,11 +955,14 @@ package body Sem_Ch10 is
Item := First (Context_Items (N)); Item := First (Context_Items (N));
while Present (Item) loop while Present (Item) loop
-- Ada 2005 (AI-50217): Do not consider limited-withed units -- Check for explicit with clause
if Nkind (Item) = N_With_Clause if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item) and then not Implicit_With (Item)
and then not Limited_Present (Item)
-- Ada 2005 (AI-50217): Ignore limited-withed units
and then not Limited_Present (Item)
then then
Nam := Entity (Name (Item)); Nam := Entity (Name (Item));
...@@ -1057,16 +1085,15 @@ package body Sem_Ch10 is ...@@ -1057,16 +1085,15 @@ package body Sem_Ch10 is
end; end;
end if; end if;
-- Finally, freeze the compilation unit entity. This for sure is needed -- Freeze the compilation unit entity. This for sure is needed because
-- because of some warnings that can be output (see Freeze_Subprogram), -- of some warnings that can be output (see Freeze_Subprogram), but may
-- but may in general be required. If freezing actions result, place -- in general be required. If freezing actions result, place them in the
-- them in the compilation unit actions list, and analyze them. -- compilation unit actions list, and analyze them.
declare declare
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
L : constant List_Id := L : constant List_Id :=
Freeze_Entity (Cunit_Entity (Current_Sem_Unit), Loc); Freeze_Entity (Cunit_Entity (Current_Sem_Unit), Loc);
begin begin
while Is_Non_Empty_List (L) loop while Is_Non_Empty_List (L) loop
Insert_Library_Level_Action (Remove_Head (L)); Insert_Library_Level_Action (Remove_Head (L));
...@@ -1096,6 +1123,49 @@ package body Sem_Ch10 is ...@@ -1096,6 +1123,49 @@ package body Sem_Ch10 is
Warning_Mode := Save_Warning; Warning_Mode := Save_Warning;
end; end;
end if; end if;
-- If we are generating obsolescent warnings, then here is where we
-- generate them for the with'ed items. The reason for this special
-- processing is that the normal mechanism of generating the warnings
-- for referenced entities does not work for context clause references.
-- That's because when we first analyze the context, it is too early to
-- know if the with'ing unit is itself obsolescent (which suppresses
-- the warnings).
if not GNAT_Mode and then Warn_On_Obsolescent_Feature then
-- Push current compilation unit as scope, so that the test for
-- being within an obsolescent unit will work correctly.
New_Scope (Defining_Entity (Unit (N)));
-- Loop through context items to deal with with clauses
declare
Item : Node_Id;
Nam : Node_Id;
Ent : Entity_Id;
begin
Item := First (Context_Items (N));
while Present (Item) loop
if Nkind (Item) = N_With_Clause then
Nam := Name (Item);
Ent := Entity (Nam);
if Is_Obsolescent (Ent) then
Output_Obsolescent_Entity_Warnings (Nam, Ent);
end if;
end if;
Next (Item);
end loop;
end;
-- Remove temporary install of current unit as scope
Pop_Scope;
end if;
end Analyze_Compilation_Unit; end Analyze_Compilation_Unit;
--------------------- ---------------------
...@@ -1272,7 +1342,7 @@ package body Sem_Ch10 is ...@@ -1272,7 +1342,7 @@ package body Sem_Ch10 is
& " context clause found #", & " context clause found #",
Item, It); Item, It);
Error_Msg_N Error_Msg_N
("simultaneous visibility of the limited" ("\simultaneous visibility of the limited"
& " and unlimited views not allowed" & " and unlimited views not allowed"
, Item); , Item);
exit; exit;
...@@ -1560,9 +1630,7 @@ package body Sem_Ch10 is ...@@ -1560,9 +1630,7 @@ package body Sem_Ch10 is
Compiler_State := Analyzing; Compiler_State := Analyzing;
if Unum /= No_Unit if Unum /= No_Unit then
and then (not Fatal_Error (Unum) or else Try_Semantics)
then
if Debug_Flag_L then if Debug_Flag_L then
Write_Str ("*** Loaded subunit from stub. Analyze"); Write_Str ("*** Loaded subunit from stub. Analyze");
Write_Eol; Write_Eol;
...@@ -1579,12 +1647,21 @@ package body Sem_Ch10 is ...@@ -1579,12 +1647,21 @@ package body Sem_Ch10 is
("expected SEPARATE subunit, found child unit", ("expected SEPARATE subunit, found child unit",
Cunit_Entity (Unum)); Cunit_Entity (Unum));
-- OK, we have a subunit, so go ahead and analyze it, -- OK, we have a subunit
-- and set Scope of entity in stub, for ASIS use.
else else
-- Set corresponding stub (even if errors)
Set_Corresponding_Stub (Unit (Comp_Unit), N); Set_Corresponding_Stub (Unit (Comp_Unit), N);
Analyze_Subunit (Comp_Unit);
-- Analyze the unit if semantics active
if not Fatal_Error (Unum) or else Try_Semantics then
Analyze_Subunit (Comp_Unit);
end if;
-- Set the library unit pointer in any case
Set_Library_Unit (N, Comp_Unit); Set_Library_Unit (N, Comp_Unit);
-- We update the version. Although we are not technically -- We update the version. Although we are not technically
...@@ -1985,6 +2062,26 @@ package body Sem_Ch10 is ...@@ -1985,6 +2062,26 @@ package body Sem_Ch10 is
Analyze (Proper_Body (Unit (N))); Analyze (Proper_Body (Unit (N)));
Remove_Context (N); Remove_Context (N);
-- The subunit may contain a with_clause on a sibling of some
-- ancestor. Removing the context will remove from visibility those
-- ancestor child units, which must be restored to the visibility
-- they have in the enclosing body.
if Present (Enclosing_Child) then
declare
C : Entity_Id;
begin
C := Current_Scope;
while Present (C)
and then Is_Child_Unit (C)
loop
Set_Is_Immediately_Visible (C);
Set_Is_Visible_Child_Unit (C);
C := Scope (C);
end loop;
end;
end if;
end Analyze_Subunit; end Analyze_Subunit;
---------------------------- ----------------------------
...@@ -2282,13 +2379,6 @@ package body Sem_Ch10 is ...@@ -2282,13 +2379,6 @@ package body Sem_Ch10 is
if Private_Present (N) then if Private_Present (N) then
Set_Is_Immediately_Visible (E_Name, False); Set_Is_Immediately_Visible (E_Name, False);
end if; end if;
-- Check for with'ing obsolescent package. Exclude subprograms here
-- since we will catch those on the call rather than the WITH.
if Is_Package_Or_Generic_Package (E_Name) then
Check_Obsolescent (E_Name, N);
end if;
end Analyze_With_Clause; end Analyze_With_Clause;
------------------------------ ------------------------------
...@@ -2760,7 +2850,7 @@ package body Sem_Ch10 is ...@@ -2760,7 +2850,7 @@ package body Sem_Ch10 is
Error_Msg_N Error_Msg_N
("unit in with clause is private child unit!", Item); ("unit in with clause is private child unit!", Item);
Error_Msg_NE Error_Msg_NE
("current unit must also have parent&!", ("\current unit must also have parent&!",
Item, Child_Parent); Item, Child_Parent);
end if; end if;
...@@ -3384,6 +3474,8 @@ package body Sem_Ch10 is ...@@ -3384,6 +3474,8 @@ package body Sem_Ch10 is
Item := First (Visible_Declarations (Spec)); Item := First (Visible_Declarations (Spec));
while Present (Item) loop while Present (Item) loop
-- Look only at use package clauses
if Nkind (Item) = N_Use_Package_Clause then if Nkind (Item) = N_Use_Package_Clause then
-- Traverse the list of packages -- Traverse the list of packages
...@@ -3397,8 +3489,11 @@ package body Sem_Ch10 is ...@@ -3397,8 +3489,11 @@ package body Sem_Ch10 is
if Nkind (Parent (E)) = N_Package_Renaming_Declaration if Nkind (Parent (E)) = N_Package_Renaming_Declaration
and then Renamed_Entity (E) = WEnt and then Renamed_Entity (E) = WEnt
then then
Error_Msg_N ("unlimited view visible through " & -- The unlimited view is visible through use clause and
"use clause and renamings", W); -- renamings. There is not need to generate the error
-- message here because Is_Visible_Through_Renamings
-- takes care of generating the precise error message.
return; return;
elsif Nkind (Parent (E)) = N_Package_Specification then elsif Nkind (Parent (E)) = N_Package_Specification then
...@@ -3421,7 +3516,6 @@ package body Sem_Ch10 is ...@@ -3421,7 +3516,6 @@ package body Sem_Ch10 is
end if; end if;
Next (Nam); Next (Nam);
end loop; end loop;
end if; end if;
Next (Item); Next (Item);
...@@ -3480,7 +3574,7 @@ package body Sem_Ch10 is ...@@ -3480,7 +3574,7 @@ package body Sem_Ch10 is
Error_Msg_N Error_Msg_N
("unit in with clause is private child unit!", Item); ("unit in with clause is private child unit!", Item);
Error_Msg_NE Error_Msg_NE
("current unit must also have parent&!", ("\current unit must also have parent&!",
Item, Defining_Unit_Name (Specification (Unit (Child_Parent)))); Item, Defining_Unit_Name (Specification (Unit (Child_Parent))));
elsif not Private_Present (Parent (Item)) elsif not Private_Present (Parent (Item))
...@@ -3546,9 +3640,12 @@ package body Sem_Ch10 is ...@@ -3546,9 +3640,12 @@ package body Sem_Ch10 is
New_Nodes_OK := New_Nodes_OK + 1; New_Nodes_OK := New_Nodes_OK + 1;
if Nkind (Nam) = N_Identifier then if Nkind (Nam) = N_Identifier then
-- Create node for name of withed unit
Withn := Withn :=
Make_With_Clause (Loc, Make_With_Clause (Loc,
Name => Nam); Name => New_Copy (Nam));
else pragma Assert (Nkind (Nam) = N_Selected_Component); else pragma Assert (Nkind (Nam) = N_Selected_Component);
Withn := Withn :=
...@@ -3644,6 +3741,53 @@ package body Sem_Ch10 is ...@@ -3644,6 +3741,53 @@ package body Sem_Ch10 is
Next (Item); Next (Item);
end loop; end loop;
-- Ada 2005 (AI-412): Examine the visible declarations of a package
-- spec, looking for incomplete subtype declarations of incomplete
-- types visible through a limited with clause.
if Ada_Version >= Ada_05
and then Analyzed (N)
and then Nkind (Unit (N)) = N_Package_Declaration
then
declare
Decl : Node_Id;
Def_Id : Entity_Id;
Non_Lim_View : Entity_Id;
begin
Decl := First (Visible_Declarations (Specification (Unit (N))));
while Present (Decl) loop
if Nkind (Decl) = N_Subtype_Declaration
and then
Ekind (Defining_Identifier (Decl)) = E_Incomplete_Subtype
and then
From_With_Type (Defining_Identifier (Decl))
then
Def_Id := Defining_Identifier (Decl);
Non_Lim_View := Non_Limited_View (Def_Id);
-- Convert an incomplete subtype declaration into a
-- corresponding non-limited view subtype declaration.
Set_Subtype_Indication (Decl,
New_Reference_To (Non_Lim_View, Sloc (Def_Id)));
Set_Etype (Def_Id, Non_Lim_View);
Set_Ekind (Def_Id, Subtype_Kind (Ekind (Non_Lim_View)));
Set_Analyzed (Decl, False);
-- Reanalyze the declaration, suppressing the call to
-- Enter_Name to avoid duplicate names.
Analyze_Subtype_Declaration
(N => Decl,
Skip => True);
end if;
Next (Decl);
end loop;
end;
end if;
end Install_Limited_Context_Clauses; end Install_Limited_Context_Clauses;
--------------------- ---------------------
...@@ -3808,7 +3952,8 @@ package body Sem_Ch10 is ...@@ -3808,7 +3952,8 @@ package body Sem_Ch10 is
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 each entity is an ancestor of the current unit. -- scope of each entity is an ancestor of the current unit, in
-- which case it is immediately visible.
Item := First (Context_Items (N)); Item := First (Context_Items (N));
while Present (Item) loop while Present (Item) loop
...@@ -3861,13 +4006,27 @@ package body Sem_Ch10 is ...@@ -3861,13 +4006,27 @@ package body Sem_Ch10 is
end; end;
end if; end if;
-- the With_Clause may be on a grand-child, which makes -- The With_Clause may be on a grand-child or one of its
-- the child immediately visible. -- further descendants, which makes a child immediately visible.
-- Examine ancestry to determine whether such a child exists.
-- For example, if current unit is A.C, and with_clause is on
-- A.X.Y.Z, then X is immediately visible.
elsif Is_Child_Unit (Scope (Id)) elsif Is_Child_Unit (Id) then
and then Is_Ancestor_Package (Scope (Scope (Id)), U_Name) declare
then Par : Entity_Id;
Set_Is_Immediately_Visible (Scope (Id));
begin
Par := Scope (Id);
while Is_Child_Unit (Par) loop
if Is_Ancestor_Package (Scope (Par), U_Name) then
Set_Is_Immediately_Visible (Par);
exit;
end if;
Par := Scope (Par);
end loop;
end;
end if; end if;
end if; end if;
...@@ -3881,6 +4040,7 @@ package body Sem_Ch10 is ...@@ -3881,6 +4040,7 @@ package body Sem_Ch10 is
procedure Install_Limited_Withed_Unit (N : Node_Id) is procedure Install_Limited_Withed_Unit (N : Node_Id) is
P_Unit : constant Entity_Id := Unit (Library_Unit (N)); P_Unit : constant Entity_Id := Unit (Library_Unit (N));
E : Entity_Id;
P : Entity_Id; P : Entity_Id;
Is_Child_Package : Boolean := False; Is_Child_Package : Boolean := False;
...@@ -3944,19 +4104,15 @@ package body Sem_Ch10 is ...@@ -3944,19 +4104,15 @@ package body Sem_Ch10 is
-- installed. -- installed.
if Kind = N_Package_Declaration then if Kind = N_Package_Declaration then
Error_Msg_N
("simultaneous visibility of the limited and" &
" 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 context" ("\unlimited view of & visible through the" &
& " clause found #", N, P); " context clause found #", N, P);
Error_Msg_Sloc := Sloc (Decl); Error_Msg_Sloc := Sloc (Decl);
Error_Msg_NE Error_Msg_NE ("\and the renaming found #", N, P);
("unlimited view of & visible through the"
& " renaming found #", N, P);
Error_Msg_N
("simultaneous visibility of the limited and"
& " unlimited views not allowed", N);
end if; end if;
return True; return True;
...@@ -4145,20 +4301,15 @@ package body Sem_Ch10 is ...@@ -4145,20 +4301,15 @@ package body Sem_Ch10 is
-- avoid its usage. This is needed to cover all the subtype decla- -- avoid its usage. This is needed to cover all the subtype decla-
-- rations because we do not remove them from the homonym chain. -- rations because we do not remove them from the homonym chain.
declare E := First_Entity (P);
E : Entity_Id; while Present (E) and then E /= First_Private_Entity (P) loop
if Is_Type (E) then
begin Set_Was_Hidden (E, Is_Hidden (E));
E := First_Entity (P); Set_Is_Hidden (E);
while Present (E) and then E /= First_Private_Entity (P) loop end if;
if Is_Type (E) then
Set_Was_Hidden (E, Is_Hidden (E));
Set_Is_Hidden (E);
end if;
Next_Entity (E); Next_Entity (E);
end loop; end loop;
end;
-- 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
...@@ -4173,25 +4324,48 @@ package body Sem_Ch10 is ...@@ -4173,25 +4324,48 @@ package body Sem_Ch10 is
loop loop
pragma Assert (not In_Chain (Lim_Typ)); pragma Assert (not In_Chain (Lim_Typ));
-- Do not unchain child units -- Do not unchain nested packages and child units
if not Is_Child_Unit (Lim_Typ) then if Ekind (Lim_Typ) /= E_Package
and then not Is_Child_Unit (Lim_Typ)
then
declare declare
Prev : Entity_Id; Prev : Entity_Id;
begin begin
Set_Homonym (Lim_Typ, Homonym (Non_Limited_View (Lim_Typ)));
Prev := Current_Entity (Lim_Typ); Prev := Current_Entity (Lim_Typ);
if Prev = Non_Limited_View (Lim_Typ) then -- Handle incomplete types
if Ekind (Prev) = E_Incomplete_Type then
E := Full_View (Prev);
else
E := Prev;
end if;
-- Replace E in the homonyms list
if E = Non_Limited_View (Lim_Typ) then
Set_Homonym (Lim_Typ, Homonym (Prev));
Set_Current_Entity (Lim_Typ); Set_Current_Entity (Lim_Typ);
else else
while Present (Prev)
and then Homonym (Prev) /= Non_Limited_View (Lim_Typ)
loop loop
E := Homonym (Prev);
pragma Assert (Present (E));
-- Handle incomplete types
if Ekind (E) = E_Incomplete_Type then
E := Full_View (E);
end if;
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)));
Set_Homonym (Prev, Lim_Typ); Set_Homonym (Prev, Lim_Typ);
end if; end if;
end; end;
...@@ -4224,6 +4398,7 @@ package body Sem_Ch10 is ...@@ -4224,6 +4398,7 @@ package body Sem_Ch10 is
declare declare
Nam : Node_Id; Nam : Node_Id;
Ent : Entity_Id; Ent : Entity_Id;
begin begin
Nam := Name (N); Nam := Name (N);
Ent := P; Ent := P;
...@@ -4231,8 +4406,21 @@ package body Sem_Ch10 is ...@@ -4231,8 +4406,21 @@ package body Sem_Ch10 is
and then Present (Ent) and then Present (Ent)
loop loop
Change_Selected_Component_To_Expanded_Name (Nam); Change_Selected_Component_To_Expanded_Name (Nam);
-- Set entity of parent identifiers if the unit is a child
-- unit. This ensures that the tree is properly formed from
-- semantic point of view (e.g. for ASIS queries).
Set_Entity (Nam, Ent);
Nam := Prefix (Nam); Nam := Prefix (Nam);
Ent := Scope (Ent); Ent := Scope (Ent);
-- Set entity of last ancestor
if Nkind (Nam) = N_Identifier then
Set_Entity (Nam, Ent);
end if;
end loop; end loop;
end; end;
end if; end if;
...@@ -4610,9 +4798,9 @@ package body Sem_Ch10 is ...@@ -4610,9 +4798,9 @@ package body Sem_Ch10 is
Set_Etype (P, Standard_Void_Type); Set_Etype (P, Standard_Void_Type);
end Decorate_Package_Specification; end Decorate_Package_Specification;
------------------------- --------------------------------
-- New_Internal_Entity -- -- New_Internal_Shadow_Entity --
------------------------- --------------------------------
function New_Internal_Shadow_Entity function New_Internal_Shadow_Entity
(Kind : Entity_Kind; (Kind : Entity_Kind;
...@@ -4665,11 +4853,19 @@ package body Sem_Ch10 is ...@@ -4665,11 +4853,19 @@ package body Sem_Ch10 is
-- 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
-- explicit keyword, or else if it is a type extension, both
-- of which can be ascertained syntactically.
if Nkind (Decl) = N_Full_Type_Declaration then if Nkind (Decl) = N_Full_Type_Declaration then
Is_Tagged := Is_Tagged :=
Nkind (Type_Definition (Decl)) = N_Record_Definition (Nkind (Type_Definition (Decl)) = N_Record_Definition
and then Tagged_Present (Type_Definition (Decl)); and then Tagged_Present (Type_Definition (Decl)))
or else
(Nkind (Type_Definition (Decl)) = N_Derived_Type_Definition
and then
Present
(Record_Extension_Part (Type_Definition (Decl))));
Comp_Typ := Defining_Identifier (Decl); Comp_Typ := Defining_Identifier (Decl);
...@@ -5076,6 +5272,7 @@ package body Sem_Ch10 is ...@@ -5076,6 +5272,7 @@ package body Sem_Ch10 is
procedure Remove_Limited_With_Clause (N : Node_Id) is procedure Remove_Limited_With_Clause (N : Node_Id) is
P_Unit : constant Entity_Id := Unit (Library_Unit (N)); P_Unit : constant Entity_Id := Unit (Library_Unit (N));
E : Entity_Id;
P : Entity_Id; P : Entity_Id;
Lim_Header : Entity_Id; Lim_Header : Entity_Id;
Lim_Typ : Entity_Id; Lim_Typ : Entity_Id;
...@@ -5137,48 +5334,66 @@ package body Sem_Ch10 is ...@@ -5137,48 +5334,66 @@ package body Sem_Ch10 is
-- from visibility at the point of installation of the limited-view. -- from visibility at the point of installation of the limited-view.
-- Now we recover the previous value of the hidden attribute. -- Now we recover the previous value of the hidden attribute.
declare E := First_Entity (P);
E : Entity_Id; while Present (E) and then E /= First_Private_Entity (P) loop
if Is_Type (E) then
begin Set_Is_Hidden (E, Was_Hidden (E));
E := First_Entity (P); end if;
while Present (E) and then E /= First_Private_Entity (P) loop
if Is_Type (E) then
Set_Is_Hidden (E, Was_Hidden (E));
end if;
Next_Entity (E); Next_Entity (E);
end loop; end loop;
end;
while Present (Lim_Typ) while Present (Lim_Typ)
and then Lim_Typ /= First_Private_Entity (Lim_Header) and then Lim_Typ /= First_Private_Entity (Lim_Header)
loop loop
pragma Assert (not In_Chain (Non_Limited_View (Lim_Typ))); -- Nested packages and child units were not unchained
if Ekind (Lim_Typ) /= E_Package
and then not Is_Child_Unit (Non_Limited_View (Lim_Typ))
then
-- Handle incomplete types of the real view. For this purpose
-- we traverse the list of visible entities to look for an
-- incomplete type in the real-view associated with Lim_Typ.
E := First_Entity (P);
while Present (E) and then E /= First_Private_Entity (P) loop
exit when Ekind (E) = E_Incomplete_Type
and then Present (Full_View (E))
and then Full_View (E) = Lim_Typ;
Next_Entity (E);
end loop;
-- If the previous search was not sucessful then the entity
-- to be restored in the homonym list is the non-limited view
-- Child units have not been unchained if E = First_Private_Entity (P) then
E := Non_Limited_View (Lim_Typ);
end if;
pragma Assert (not In_Chain (E));
if not Is_Child_Unit (Non_Limited_View (Lim_Typ)) then
Prev := Current_Entity (Lim_Typ); Prev := Current_Entity (Lim_Typ);
if Prev = Lim_Typ then if Prev = Lim_Typ then
Set_Current_Entity (Non_Limited_View (Lim_Typ)); Set_Current_Entity (E);
else else
while Present (Prev) while Present (Prev)
and then Homonym (Prev) /= Lim_Typ and then Homonym (Prev) /= Lim_Typ
loop loop
Prev := Homonym (Prev); Prev := Homonym (Prev);
end loop; end loop;
pragma Assert (Present (Prev)); pragma Assert (Present (Prev));
Set_Homonym (Prev, Non_Limited_View (Lim_Typ));
Set_Homonym (Prev, E);
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
-- to handle the case in which the next homonym was a shadow -- to handle the case in which the next homonym was a shadow
-- entity. -- entity.
Set_Homonym (Non_Limited_View (Lim_Typ), Homonym (Lim_Typ)); Set_Homonym (E, Homonym (Lim_Typ));
end if; end if;
Next_Entity (Lim_Typ); Next_Entity (Lim_Typ);
...@@ -5243,6 +5458,33 @@ package body Sem_Ch10 is ...@@ -5243,6 +5458,33 @@ package body Sem_Ch10 is
end if; end if;
end Remove_Parents; end Remove_Parents;
---------------------------------
-- Remove_Private_With_Clauses --
---------------------------------
procedure Remove_Private_With_Clauses (Comp_Unit : Node_Id) is
Item : Node_Id;
begin
Item := First (Context_Items (Comp_Unit));
while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then Private_Present (Item)
then
if Limited_Present (Item) then
if not Limited_View_Installed (Item) then
Remove_Limited_With_Clause (Item);
end if;
else
Remove_Unit_From_Visibility (Entity (Name (Item)));
Set_Context_Installed (Item, False);
end if;
end if;
Next (Item);
end loop;
end Remove_Private_With_Clauses;
----------------------------- -----------------------------
-- Remove_With_Type_Clause -- -- Remove_With_Type_Clause --
----------------------------- -----------------------------
......
gcc/ada/sem_ch10.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- -- Copyright (C) 1992-2006 Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -53,6 +53,13 @@ package Sem_Ch10 is ...@@ -53,6 +53,13 @@ package Sem_Ch10 is
-- end of the main unit the visibility table won't be needed in any case. -- end of the main unit the visibility table won't be needed in any case.
-- For a child unit, remove parents and their context as well. -- For a child unit, remove parents and their context as well.
procedure Remove_Private_With_Clauses (Comp_Unit : Node_Id);
-- The private_with_clauses of a compilation unit are visible in the
-- private part of a nested package, even if this package appears in
-- the visible part of the enclosing compilation unit. This Ada 2005
-- rule imposes extra steps in order to install/remove the private_with
-- clauses of the an enclosing unit.
procedure Load_Needed_Body (N : Node_Id; OK : out Boolean); procedure Load_Needed_Body (N : Node_Id; OK : out Boolean);
-- Load and analyze the body of a context unit that is generic, or -- Load and analyze the body of a context unit that is generic, or
-- that contains generic units or inlined units. The body becomes -- that contains generic units or inlined units. The body becomes
......
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