Skip to content

R
riscv-gcc-1
Commit dc59bed2 by Hristian Kirtchev Committed by Pierre-Marie de Rodat
Options

[Ada] Spurious error due to lingering limited view 

This patch modifies the mechanism which manages [private] with clauses to
uninstall a limited with clause if a non-limited with clause is given for
the same package.

The management of with clauses already prevents the installation of a limited
with clause if the related package is already withed though a non-limited with
clause. The timing of parent unit with clause processing is such that the non-
limited clauses of the child unit are first installed, followed by the clauses
of the parent. This order prevents a limited with clause from "overriding" a
non-limited with clause.

Private with clauses however break this model because they are processed when
the private part of a package is entered. Since private with clauses are non-
limited with clauses, they must "override" the effects of any limited clauses
which import the same packages. This effect is now correctly achieved by
uninstalling the limited with clauses when private with clauses are activated.

------------
-- Source --
------------

--  server.ads

package Server is
   type Root is tagged private;
private
   type Root is tagged null record;
end Server;

--  parent.ads

limited with Server;

package Parent is end Parent;

--  parent-client.ads

private with Server;

package Parent.Client is
   type Deriv is tagged private;
private
   type Deriv is new Server.Root with null record;
end Parent.Client;

-----------------
-- Compilation --
-----------------

$ gcc -c parent-client.ads

2018-05-24  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* sem_ch10.adb (Expand_Limited_With_Clause): Update the call to
	Install_Limited_Withed_Unit.
	(Expand_With_Clause): Update the call to Install_Withed_Unit.
	(Implicit_With_On_Parent): Update the call to Install_Withed_Unit.
	(Install_Context_Clauses): Update the call to Install_Withed_Unit.
	(Install_Limited_Context_Clauses): Update the calls to
	 Install_Limited_Withed_Unit.
	(Install_Limited_Withed_Unit): Renamed to better illustrate its
	purpose.
	(Install_Private_With_Clauses): Update the calls to Install_Withed_Unit
	and Install_Limited_Withed_Unit.
	(Install_With_Clause): Uninstall a limited with clause if a [private]
	with clause is given for the same package.
	(Install_Withed_Unit): Renamed to better illustrate its purpose.
	(Remove_Limited_With_Unit): New routine.

From-SVN: r260660
parent 45c6d784
Showing with 306 additions and 149 deletions
gcc/ada/ChangeLog
2018-05-24 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch10.adb (Expand_Limited_With_Clause): Update the call to
Install_Limited_Withed_Unit.
(Expand_With_Clause): Update the call to Install_Withed_Unit.
(Implicit_With_On_Parent): Update the call to Install_Withed_Unit.
(Install_Context_Clauses): Update the call to Install_Withed_Unit.
(Install_Limited_Context_Clauses): Update the calls to
Install_Limited_Withed_Unit.
(Install_Limited_Withed_Unit): Renamed to better illustrate its
purpose.
(Install_Private_With_Clauses): Update the calls to Install_Withed_Unit
and Install_Limited_Withed_Unit.
(Install_With_Clause): Uninstall a limited with clause if a [private]
with clause is given for the same package.
(Install_Withed_Unit): Renamed to better illustrate its purpose.
(Remove_Limited_With_Unit): New routine.
2018-05-24 Eric Botcazou <ebotcazou@adacore.com> 2018-05-24 Eric Botcazou <ebotcazou@adacore.com>
* raise-gcc.c (__gnat_SEH_error_handler): Remove prototype. * raise-gcc.c (__gnat_SEH_error_handler): Remove prototype.
......
gcc/ada/sem_ch10.adb
...@@ -150,19 +150,10 @@ package body Sem_Ch10 is ...@@ -150,19 +150,10 @@ package body Sem_Ch10 is
-- Subsidiary to Install_Context. Process only limited with_clauses for -- Subsidiary to Install_Context. Process only limited with_clauses for
-- current unit. Implements Ada 2005 (AI-50217). -- current unit. Implements Ada 2005 (AI-50217).
procedure Install_Limited_Withed_Unit (N : Node_Id); procedure Install_Limited_With_Clause (N : Node_Id);
-- Place shadow entities for a limited_with package in the visibility -- Place shadow entities for a limited_with package in the visibility
-- structures for the current compilation. Implements Ada 2005 (AI-50217). -- structures for the current compilation. Implements Ada 2005 (AI-50217).
procedure Install_Withed_Unit
(With_Clause : Node_Id;
Private_With_OK : Boolean := False);
-- If the unit is not a child unit, make unit immediately visible. The
-- caller ensures that the unit is not already currently installed. The
-- flag Private_With_OK is set true in Install_Private_With_Clauses, which
-- is called when compiling the private part of a package, or installing
-- the private declarations of a parent unit.
procedure Install_Parents procedure Install_Parents
(Lib_Unit : Node_Id; (Lib_Unit : Node_Id;
Is_Private : Boolean; Is_Private : Boolean;
...@@ -185,6 +176,15 @@ package body Sem_Ch10 is ...@@ -185,6 +176,15 @@ package body Sem_Ch10 is
-- an enclosing scope. Iterate over context to find child units of U_Name -- an enclosing scope. Iterate over context to find child units of U_Name
-- or of some ancestor of it. -- or of some ancestor of it.
procedure Install_With_Clause
(With_Clause : Node_Id;
Private_With_OK : Boolean := False);
-- If the unit is not a child unit, make unit immediately visible. The
-- caller ensures that the unit is not already currently installed. The
-- flag Private_With_OK is set true in Install_Private_With_Clauses, which
-- is called when compiling the private part of a package, or installing
-- the private declarations of a parent unit.
function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean; function Is_Ancestor_Unit (U1 : Node_Id; U2 : Node_Id) return Boolean;
-- When compiling a unit Q descended from some parent unit P, a limited -- When compiling a unit Q descended from some parent unit P, a limited
-- with_clause in the context of P that names some other ancestor of Q -- with_clause in the context of P that names some other ancestor of Q
...@@ -204,8 +204,15 @@ package body Sem_Ch10 is ...@@ -204,8 +204,15 @@ package body Sem_Ch10 is
-- Subsidiary of previous one. Remove use_ and with_clauses -- Subsidiary of previous one. Remove use_ and with_clauses
procedure Remove_Limited_With_Clause (N : Node_Id); procedure Remove_Limited_With_Clause (N : Node_Id);
-- Remove from visibility the shadow entities introduced for a package -- Remove the shadow entities from visibility introduced for a package
-- mentioned in a limited_with clause. Implements Ada 2005 (AI-50217). -- mentioned in limited with clause N. Implements Ada 2005 (AI-50217).
procedure Remove_Limited_With_Unit
(Pack_Decl : Node_Id;
Lim_Clause : Node_Id := Empty);
-- Remove the shadow entities from visibility introduced for a package
-- denoted by declaration Pack_Decl. Lim_Clause is the related limited
-- with clause, if any. Implements Ada 2005 (AI-50217).
procedure Remove_Parents (Lib_Unit : Node_Id); procedure Remove_Parents (Lib_Unit : Node_Id);
-- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent -- Remove_Parents checks if Lib_Unit is a child spec. If so then the parent
...@@ -248,7 +255,7 @@ package body Sem_Ch10 is ...@@ -248,7 +255,7 @@ package body Sem_Ch10 is
-- of the package. Links between corresponding entities in both chains -- of the package. Links between corresponding entities in both chains
-- allow the compiler to select the proper view of a given type, depending -- allow the compiler to select the proper view of a given type, depending
-- on the context. Note that in contrast with the handling of private -- on the context. Note that in contrast with the handling of private
-- types, the limited view and the non-limited view of a type are treated -- types, the limited view and the nonlimited view of a type are treated
-- as separate entities, and no entity exchange needs to take place, which -- as separate entities, and no entity exchange needs to take place, which
-- makes the implementation much simpler than could be feared. -- makes the implementation much simpler than could be feared.
...@@ -1387,7 +1394,7 @@ package body Sem_Ch10 is ...@@ -1387,7 +1394,7 @@ package body Sem_Ch10 is
-- Loop through actual context items. This is done in two passes: -- Loop through actual context items. This is done in two passes:
-- a) The first pass analyzes non-limited with-clauses and also any -- a) The first pass analyzes nonlimited with clauses and also any
-- configuration pragmas (we need to get the latter analyzed right -- configuration pragmas (we need to get the latter analyzed right
-- away, since they can affect processing of subsequent items). -- away, since they can affect processing of subsequent items).
...@@ -3182,7 +3189,8 @@ package body Sem_Ch10 is ...@@ -3182,7 +3189,8 @@ package body Sem_Ch10 is
Prepend (Withn, Context_Items (N)); Prepend (Withn, Context_Items (N));
Mark_Rewrite_Insertion (Withn); Mark_Rewrite_Insertion (Withn);
Install_Withed_Unit (Withn);
Install_With_Clause (Withn);
-- If we have "with X.Y;", we want to recurse on "X", except in the -- If we have "with X.Y;", we want to recurse on "X", except in the
-- unusual case where X.Y is a renaming of X. In that case, the scope -- unusual case where X.Y is a renaming of X. In that case, the scope
...@@ -3395,7 +3403,8 @@ package body Sem_Ch10 is ...@@ -3395,7 +3403,8 @@ package body Sem_Ch10 is
Prepend (Withn, Context_Items (N)); Prepend (Withn, Context_Items (N));
Mark_Rewrite_Insertion (Withn); Mark_Rewrite_Insertion (Withn);
Install_Withed_Unit (Withn);
Install_With_Clause (Withn);
if Is_Child_Spec (P_Unit) then if Is_Child_Spec (P_Unit) then
Implicit_With_On_Parent (P_Unit, N); Implicit_With_On_Parent (P_Unit, N);
...@@ -3501,7 +3510,7 @@ package body Sem_Ch10 is ...@@ -3501,7 +3510,7 @@ package body Sem_Ch10 is
Check_Private := True; Check_Private := True;
end if; end if;
Install_Withed_Unit (Item); Install_With_Clause (Item);
Decl_Node := Unit_Declaration_Node (Uname_Node); Decl_Node := Unit_Declaration_Node (Uname_Node);
...@@ -3905,7 +3914,7 @@ package body Sem_Ch10 is ...@@ -3905,7 +3914,7 @@ package body Sem_Ch10 is
function Previous_Withed_Unit (W : Node_Id) return Boolean; function Previous_Withed_Unit (W : Node_Id) return Boolean;
-- Returns true if the context already includes a with_clause for -- Returns true if the context already includes a with_clause for
-- this unit. If the with_clause is non-limited, the unit is fully -- this unit. If the with_clause is nonlimited, the unit is fully
-- visible and an implicit limited_with should not be created. If -- visible and an implicit limited_with should not be created. If
-- there is already a limited_with clause for W, a second one is -- there is already a limited_with clause for W, a second one is
-- simply redundant. -- simply redundant.
...@@ -3992,7 +4001,7 @@ package body Sem_Ch10 is ...@@ -3992,7 +4001,7 @@ package body Sem_Ch10 is
Analyze (Withn); Analyze (Withn);
if not Limited_View_Installed (Withn) then if not Limited_View_Installed (Withn) then
Install_Limited_Withed_Unit (Withn); Install_Limited_With_Clause (Withn);
end if; end if;
end if; end if;
end Expand_Limited_With_Clause; end Expand_Limited_With_Clause;
...@@ -4039,7 +4048,7 @@ package body Sem_Ch10 is ...@@ -4039,7 +4048,7 @@ package body Sem_Ch10 is
N_Subprogram_Body, N_Subprogram_Body,
N_Subunit) N_Subunit)
then then
Install_Limited_Withed_Unit (Item); Install_Limited_With_Clause (Item);
end if; end if;
end if; end if;
end if; end if;
...@@ -4075,12 +4084,12 @@ package body Sem_Ch10 is ...@@ -4075,12 +4084,12 @@ package body Sem_Ch10 is
if not Is_Incomplete_Type (Non_Lim_View) then if not Is_Incomplete_Type (Non_Lim_View) then
-- Convert an incomplete subtype declaration into a -- Convert an incomplete subtype declaration into a
-- corresponding non-limited view subtype declaration. -- corresponding nonlimited view subtype declaration.
-- 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 nonlimited 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.
...@@ -4262,10 +4271,10 @@ package body Sem_Ch10 is ...@@ -4262,10 +4271,10 @@ package body Sem_Ch10 is
not Is_Ancestor_Unit (Library_Unit (Item), not Is_Ancestor_Unit (Library_Unit (Item),
Cunit (Current_Sem_Unit)) Cunit (Current_Sem_Unit))
then then
Install_Limited_Withed_Unit (Item); Install_Limited_With_Clause (Item);
end if; end if;
else else
Install_Withed_Unit (Item, Private_With_OK => True); Install_With_Clause (Item, Private_With_OK => True);
end if; end if;
end if; end if;
...@@ -4430,10 +4439,10 @@ package body Sem_Ch10 is ...@@ -4430,10 +4439,10 @@ package body Sem_Ch10 is
end Install_Siblings; end Install_Siblings;
--------------------------------- ---------------------------------
-- Install_Limited_Withed_Unit -- -- Install_Limited_With_Clause --
--------------------------------- ---------------------------------
procedure Install_Limited_Withed_Unit (N : Node_Id) is procedure Install_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; E : Entity_Id;
P : Entity_Id; P : Entity_Id;
...@@ -4890,7 +4899,7 @@ package body Sem_Ch10 is ...@@ -4890,7 +4899,7 @@ package body Sem_Ch10 is
return False; return False;
end Is_Visible_Through_Renamings; end Is_Visible_Through_Renamings;
-- Start of processing for Install_Limited_Withed_Unit -- Start of processing for Install_Limited_With_Clause
begin begin
pragma Assert (not Limited_View_Installed (N)); pragma Assert (not Limited_View_Installed (N));
...@@ -4951,7 +4960,7 @@ package body Sem_Ch10 is ...@@ -4951,7 +4960,7 @@ package body Sem_Ch10 is
-- compilation of sibling Par.Sib forces the load of parent Par which -- compilation of sibling Par.Sib forces the load of parent Par which
-- tries to install the limited view of Lim_Pack [1]. However Par.Sib -- tries to install the limited view of Lim_Pack [1]. However Par.Sib
-- has a with clause for Lim_Pack [2] in its body, and thus needs the -- has a with clause for Lim_Pack [2] in its body, and thus needs the
-- non-limited views of all entities from Lim_Pack. -- nonlimited views of all entities from Lim_Pack.
-- limited with Lim_Pack; -- [1] -- limited with Lim_Pack; -- [1]
-- package Par is ... package Lim_Pack is ... -- package Par is ... package Lim_Pack is ...
...@@ -5157,7 +5166,7 @@ package body Sem_Ch10 is ...@@ -5157,7 +5166,7 @@ package body Sem_Ch10 is
-- Replace E in the homonyms list, so that the limited view -- Replace E in the homonyms list, so that the limited view
-- becomes available. -- becomes available.
-- If the non-limited view is a record with an anonymous -- If the nonlimited view is a record with an anonymous
-- self-referential component, the analysis of the record -- self-referential component, the analysis of the record
-- declaration creates an incomplete type with the same name -- declaration creates an incomplete type with the same name
-- in order to define an internal access type. The visible -- in order to define an internal access type. The visible
...@@ -5259,13 +5268,13 @@ package body Sem_Ch10 is ...@@ -5259,13 +5268,13 @@ package body Sem_Ch10 is
Set_Entity (Name (N), P); Set_Entity (Name (N), P);
Set_From_Limited_With (P); Set_From_Limited_With (P);
end Install_Limited_Withed_Unit; end Install_Limited_With_Clause;
------------------------- -------------------------
-- Install_Withed_Unit -- -- Install_With_Clause --
------------------------- -------------------------
procedure Install_Withed_Unit procedure Install_With_Clause
(With_Clause : Node_Id; (With_Clause : Node_Id;
Private_With_OK : Boolean := False) Private_With_OK : Boolean := False)
is is
...@@ -5378,11 +5387,21 @@ package body Sem_Ch10 is ...@@ -5378,11 +5387,21 @@ package body Sem_Ch10 is
Set_Context_Installed (With_Clause); Set_Context_Installed (With_Clause);
end if; end if;
-- A with-clause overrides a with-type clause: there are no restric- -- A [private] with clause overrides a limited with clause. Restore the
-- tions on the use of package entities. -- proper view of the package by performing the following actions:
--
if Ekind (Uname) = E_Package then -- * Remove all shadow entities which hide their corresponding
Set_From_Limited_With (Uname, False); -- entities from direct visibility by updating the entity and
-- homonym chains.
--
-- * Enter the corresponding entities back in direct visibility
--
-- Note that the original limited with clause which installed its view
-- is still marked as "active". This effect is undone when the clause
-- itself is removed, see Remove_Limited_With_Clause.
if Ekind (Uname) = E_Package and then From_Limited_With (Uname) then
Remove_Limited_With_Unit (Unit_Declaration_Node (Uname));
end if; end if;
-- Ada 2005 (AI-377): it is illegal for a with_clause to name a child -- Ada 2005 (AI-377): it is illegal for a with_clause to name a child
...@@ -5454,7 +5473,7 @@ package body Sem_Ch10 is ...@@ -5454,7 +5473,7 @@ package body Sem_Ch10 is
end loop; end loop;
end; end;
end if; end if;
end Install_Withed_Unit; end Install_With_Clause;
------------------- -------------------
-- Is_Child_Spec -- -- Is_Child_Spec --
...@@ -5994,9 +6013,10 @@ package body Sem_Ch10 is ...@@ -5994,9 +6013,10 @@ package body Sem_Ch10 is
Build_Shadow_Entity (Def_Id, Scop, Shadow); Build_Shadow_Entity (Def_Id, Scop, Shadow);
Process_Declarations_And_States Process_Declarations_And_States
(Pack => Def_Id, (Pack => Def_Id,
Decls => Visible_Declarations (Specification (Decl)), Decls =>
Scop => Shadow, Visible_Declarations (Specification (Decl)),
Scop => Shadow,
Create_Abstract_Views => Create_Abstract_Views); Create_Abstract_Views => Create_Abstract_Views);
-- Types -- Types
...@@ -6166,9 +6186,9 @@ package body Sem_Ch10 is ...@@ -6166,9 +6186,9 @@ package body Sem_Ch10 is
-- variables and types. -- variables and types.
Process_Declarations_And_States Process_Declarations_And_States
(Pack => Pack, (Pack => Pack,
Decls => Visible_Declarations (Spec), Decls => Visible_Declarations (Spec),
Scop => Pack, Scop => Pack,
Create_Abstract_Views => True); Create_Abstract_Views => True);
Last_Public_Shadow := Last_Shadow; Last_Public_Shadow := Last_Shadow;
...@@ -6177,9 +6197,9 @@ package body Sem_Ch10 is ...@@ -6177,9 +6197,9 @@ package body Sem_Ch10 is
-- to accommodate limited private with clauses. -- to accommodate limited private with clauses.
Process_Declarations_And_States Process_Declarations_And_States
(Pack => Pack, (Pack => Pack,
Decls => Private_Declarations (Spec), Decls => Private_Declarations (Spec),
Scop => Pack, Scop => Pack,
Create_Abstract_Views => False); Create_Abstract_Views => False);
if Present (Last_Public_Shadow) then if Present (Last_Public_Shadow) then
...@@ -6423,149 +6443,268 @@ package body Sem_Ch10 is ...@@ -6423,149 +6443,268 @@ 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)); Pack_Decl : constant Entity_Id := Unit (Library_Unit (N));
E : Entity_Id;
P : Entity_Id;
Lim_Header : Entity_Id;
Lim_Typ : Entity_Id;
Prev : Entity_Id;
begin begin
pragma Assert (Limited_View_Installed (N)); pragma Assert (Limited_View_Installed (N));
-- In case of limited with_clause on subprograms, generics, instances, -- Limited with clauses that designate units other than packages are
-- or renamings, the corresponding error was previously posted and we -- illegal and are never installed.
-- have nothing to do here.
if Nkind (P_Unit) /= N_Package_Declaration then if Nkind (Pack_Decl) = N_Package_Declaration then
return; Remove_Limited_With_Unit (Pack_Decl, N);
end if; end if;
P := Defining_Unit_Name (Specification (P_Unit)); -- Indicate that the limited views of the clause have been removed
-- Handle child packages Set_Limited_View_Installed (N, False);
end Remove_Limited_With_Clause;
if Nkind (P) = N_Defining_Program_Unit_Name then ------------------------------
P := Defining_Identifier (P); -- Remove_Limited_With_Unit --
end if; ------------------------------
if Debug_Flag_I then procedure Remove_Limited_With_Unit
Write_Str ("remove limited view of "); (Pack_Decl : Node_Id;
Write_Name (Chars (P)); Lim_Clause : Node_Id := Empty)
Write_Str (" from visibility"); is
Write_Eol; procedure Remove_Shadow_Entities_From_Visibility (Pack_Id : Entity_Id);
end if; -- Remove the shadow entities of package Pack_Id from direct visibility
-- Prepare the removal of the shadow entities from visibility. The first procedure Remove_Shadow_Entities_With_Restore (Pack_Id : Entity_Id);
-- element of the limited view is a header (an E_Package entity) that is -- Remove the shadow entities of package Pack_Id from direct visibility,
-- used to reference the first shadow entity in the private part of the -- restore the corresponding entities they hide into direct visibility,
-- package -- and update the entity and homonym chains.
Lim_Header := Limited_View (P); --------------------------------------------
Lim_Typ := First_Entity (Lim_Header); -- Remove_Shadow_Entities_From_Visibility --
--------------------------------------------
-- Remove package and shadow entities from visibility if it has not procedure Remove_Shadow_Entities_From_Visibility (Pack_Id : Entity_Id) is
-- been analyzed Lim_Header : constant Entity_Id := Limited_View (Pack_Id);
Upto : constant Entity_Id := First_Private_Entity (Lim_Header);
if not Analyzed (P_Unit) then Shadow : Entity_Id;
Unchain (P);
Set_Is_Immediately_Visible (P, False);
while Present (Lim_Typ) loop begin
Unchain (Lim_Typ); -- Remove the package from direct visibility
Next_Entity (Lim_Typ);
Unchain (Pack_Id);
Set_Is_Immediately_Visible (Pack_Id, False);
-- Remove all shadow entities from direct visibility
Shadow := First_Entity (Lim_Header);
while Present (Shadow) and then Shadow /= Upto loop
Unchain (Shadow);
Next_Entity (Shadow);
end loop; end loop;
end Remove_Shadow_Entities_From_Visibility;
-- Otherwise this package has already appeared in the closure and its -----------------------------------------
-- shadow entities must be replaced by its real entities. This code -- Remove_Shadow_Entities_With_Restore --
-- must be kept synchronized with the complementary code in Install -----------------------------------------
-- Limited_Withed_Unit.
else procedure Remove_Shadow_Entities_With_Restore (Pack_Id : Entity_Id) is
-- If the limited_with_clause is in some other unit in the context procedure Restore_Chain_For_Shadow (Shadow : Entity_Id);
-- then it is not visible in the main unit. -- Remove shadow entity Shadow by updating the entity and homonym
-- chains.
if not In_Extended_Main_Source_Unit (N) then procedure Restore_Chains
Set_Is_Immediately_Visible (P, False); (From : Entity_Id;
end if; Upto : Entity_Id);
-- Remove a sequence of shadow entities starting from From and ending
-- prior to Upto by updating the entity and homonym chains.
-- Real entities that are type or subtype declarations were hidden procedure Restore_Type_Visibility
-- from visibility at the point of installation of the limited-view. (From : Entity_Id;
-- Now we recover the previous value of the hidden attribute. Upto : Entity_Id);
-- Restore a sequence of types starting from From and ending prior to
-- Upto back in direct visibility.
E := First_Entity (P); ------------------------------
while Present (E) and then E /= First_Private_Entity (P) loop -- Restore_Chain_For_Shadow --
if Is_Type (E) then ------------------------------
Set_Is_Hidden (E, Was_Hidden (E));
procedure Restore_Chain_For_Shadow (Shadow : Entity_Id) is
Prev : Entity_Id;
Typ : Entity_Id;
begin
-- If the package has incomplete types, the limited view of the
-- incomplete type is in fact never visible (AI05-129) but we
-- have created a shadow entity E1 for it, that points to E2,
-- a nonlimited incomplete type. This in turn has a full view
-- E3 that is the full declaration. There is a corresponding
-- shadow entity E4. When reinstalling the nonlimited view,
-- E2 must become the current entity and E3 must be ignored.
Typ := Non_Limited_View (Shadow);
-- Shadow is the limited view of a full type declaration that has
-- a previous incomplete declaration, i.e. E3 from the previous
-- description. Nothing to insert.
if Present (Current_Entity (Typ))
and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type
and then Full_View (Current_Entity (Typ)) = Typ
then
return;
end if; end if;
Next_Entity (E); pragma Assert (not In_Chain (Typ));
end loop;
while Present (Lim_Typ) Prev := Current_Entity (Shadow);
and then Lim_Typ /= First_Private_Entity (Lim_Header)
loop
-- Nested packages and child units were not unchained
if Ekind (Lim_Typ) /= E_Package if Prev = Shadow then
and then not Is_Child_Unit (Non_Limited_View (Lim_Typ)) Set_Current_Entity (Typ);
then
-- If the package has incomplete types, the limited view of the else
-- incomplete type is in fact never visible (AI05-129) but we while Present (Prev) and then Homonym (Prev) /= Shadow loop
-- have created a shadow entity E1 for it, that points to E2, Prev := Homonym (Prev);
-- a non-limited incomplete type. This in turn has a full view end loop;
-- E3 that is the full declaration. There is a corresponding
-- shadow entity E4. When reinstalling the non-limited view, if Present (Prev) then
-- E2 must become the current entity and E3 must be ignored. Set_Homonym (Prev, Typ);
end if;
E := Non_Limited_View (Lim_Typ); end if;
if Present (Current_Entity (E)) Set_Homonym (Typ, Homonym (Shadow));
and then Ekind (Current_Entity (E)) = E_Incomplete_Type end Restore_Chain_For_Shadow;
and then Full_View (Current_Entity (E)) = E
then --------------------
-- Restore_Chains --
--------------------
procedure Restore_Chains
(From : Entity_Id;
Upto : Entity_Id)
is
Shadow : Entity_Id;
begin
Shadow := From;
while Present (Shadow) and then Shadow /= Upto loop
-- Lim_Typ is the limited view of a full type declaration -- Do not unchain nested packages and child units
-- that has a previous incomplete declaration, i.e. E3 from
-- the previous description. Nothing to insert.
if Ekind (Shadow) = E_Package then
null;
elsif Is_Child_Unit (Non_Limited_View (Shadow)) then
null; null;
else else
pragma Assert (not In_Chain (E)); Restore_Chain_For_Shadow (Shadow);
end if;
Prev := Current_Entity (Lim_Typ); Next_Entity (Shadow);
end loop;
end Restore_Chains;
if Prev = Lim_Typ then -----------------------------
Set_Current_Entity (E); -- Restore_Type_Visibility --
-----------------------------
else procedure Restore_Type_Visibility
while Present (Prev) (From : Entity_Id;
and then Homonym (Prev) /= Lim_Typ Upto : Entity_Id)
loop is
Prev := Homonym (Prev); Typ : Entity_Id;
end loop;
if Present (Prev) then begin
Set_Homonym (Prev, E); Typ := From;
end if; while Present (Typ) and then Typ /= Upto loop
end if; if Is_Type (Typ) then
Set_Is_Hidden (Typ, Was_Hidden (Typ));
end if;
-- Preserve structure of homonym chain Next_Entity (Typ);
end loop;
end Restore_Type_Visibility;
Set_Homonym (E, Homonym (Lim_Typ)); -- Local variables
end if;
end if;
Next_Entity (Lim_Typ); Lim_Header : constant Entity_Id := Limited_View (Pack_Id);
end loop;
-- Start of processing Remove_Shadow_Entities_With_Restore
begin
-- The limited view of a package is being uninstalled by removing
-- the effects of a limited with clause. If the clause appears in a
-- unit which is not part of the main unit closure, then the related
-- package must not be visible.
if Present (Lim_Clause)
and then not In_Extended_Main_Source_Unit (Lim_Clause)
then
Set_Is_Immediately_Visible (Pack_Id, False);
-- Otherwise a limited view is being overridden by a nonlimited view.
-- Leave the visibility of the package as is because the unit must be
-- visible when the nonlimited view is installed.
else
null;
end if;
-- Remove the shadow entities from visibility by updating the entity
-- and homonym chains.
Restore_Chains
(From => First_Entity (Lim_Header),
Upto => First_Private_Entity (Lim_Header));
-- Reinstate the types that were hidden by the shadow entities back
-- into direct visibility.
Restore_Type_Visibility
(From => First_Entity (Pack_Id),
Upto => First_Private_Entity (Pack_Id));
end Remove_Shadow_Entities_With_Restore;
-- Local variables
Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
-- Start of processing for Remove_Limited_With_Unit
begin
-- Nothing to do when the limited view of the package is not installed
if not From_Limited_With (Pack_Id) then
return;
end if;
if Debug_Flag_I then
Write_Str ("remove limited view of ");
Write_Name (Chars (Pack_Id));
Write_Str (" from visibility");
Write_Eol;
end if;
-- The package already appears in the compilation closure. As a result,
-- its shadow entities must be replaced by the real entities they hide
-- and the previously hidden entities must be entered back into direct
-- visibility.
-- WARNING: This code must be kept synchronized with that of routine
-- Install_Limited_Withed_Clause.
if Analyzed (Pack_Decl) then
Remove_Shadow_Entities_With_Restore (Pack_Id);
-- Otherwise the package is not analyzed and its shadow entities must be
-- removed from direct visibility.
else
Remove_Shadow_Entities_From_Visibility (Pack_Id);
end if; end if;
-- Indicate that the limited view of the package is not installed -- Indicate that the limited view of the package is not installed
Set_From_Limited_With (P, False); Set_From_Limited_With (Pack_Id, False);
Set_Limited_View_Installed (N, False); end Remove_Limited_With_Unit;
end Remove_Limited_With_Clause;
-------------------- --------------------
-- Remove_Parents -- -- Remove_Parents --
......
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