-- If the main unit is a child unit, implicit withs are also added for
-- all its ancestors.
+ function In_Chain (E : Entity_Id) return Boolean;
+ -- Check that the shadow entity is not already in the homonym chain, for
+ -- example through a limited_with clause in a parent unit.
+
procedure Install_Context_Clauses (N : Node_Id);
-- Subsidiary to Install_Context and Install_Parents. Process only with_
-- and use_clauses for current unit and its library unit if any.
if Nkind (Item) = N_With_Clause
and then not Limited_Present (Item)
then
-
-- Skip analyzing with clause if no unit, nothing to do (this
-- happens for a with that references a non-existant unit)
if Ukind /= N_Package_Declaration
and then Ukind /= N_Subprogram_Declaration
- and then Ukind /= N_Subprogram_Renaming_Declaration
- and then Ukind /= N_Generic_Package_Declaration
- and then Ukind /= N_Generic_Package_Renaming_Declaration
- and then Ukind /= N_Generic_Subprogram_Declaration
- and then Ukind /= N_Generic_Procedure_Renaming_Declaration
- and then Ukind /= N_Package_Instantiation
and then Ukind /= N_Package_Renaming_Declaration
- and then Ukind /= N_Procedure_Instantiation
+ and then Ukind /= N_Subprogram_Renaming_Declaration
+ and then Ukind not in N_Generic_Declaration
+ and then Ukind not in N_Generic_Renaming_Declaration
+ and then Ukind not in N_Generic_Instantiation
then
Error_Msg_N ("limited with_clause not allowed here", Item);
or else Nkind (Parent (N)) = N_Subprogram_Body
then
Decl := First (Declarations (Parent (N)));
-
while Present (Decl)
and then Decl /= N
loop
begin
Analyze_Context (N);
- Item := First (Context_Items (N));
- -- make withed units immediately visible. If child unit, make the
+ -- Make withed units immediately visible. If child unit, make the
-- ultimate parent immediately visible.
+ Item := First (Context_Items (N));
while Present (Item) loop
-
if Nkind (Item) = N_With_Clause then
- -- Protect the frontend against previous errors
- -- in context clauses
+
+ -- Protect frontend against previous errors in context clauses
if Nkind (Name (Item)) /= N_Selected_Component then
Unit_Name := Entity (Name (Item));
-
while Is_Child_Unit (Unit_Name) loop
Set_Is_Visible_Child_Unit (Unit_Name);
Unit_Name := Scope (Unit_Name);
elsif Nkind (Item) = N_Use_Package_Clause then
Nam := First (Names (Item));
-
while Present (Nam) loop
Analyze (Nam);
Next (Nam);
elsif Nkind (Item) = N_Use_Type_Clause then
Nam := First (Subtype_Marks (Item));
-
while Present (Nam) loop
Analyze (Nam);
Next (Nam);
Next (Item);
end loop;
- Item := First (Context_Items (N));
-
- -- reset visibility of withed units. They will be made visible
+ -- Reset visibility of withed units. They will be made visible
-- again when we install the subunit context.
+ Item := First (Context_Items (N));
while Present (Item) loop
-
if Nkind (Item) = N_With_Clause
- -- Protect the frontend against previous errors in context
- -- clauses
+ -- Protect frontend against previous errors in context clauses
and then Nkind (Name (Item)) /= N_Selected_Component
then
Unit_Name := Entity (Name (Item));
-
while Is_Child_Unit (Unit_Name) loop
Set_Is_Visible_Child_Unit (Unit_Name, False);
Unit_Name := Scope (Unit_Name);
Next (Item);
end loop;
-
end Analyze_Subunit_Context;
------------------------
Set_Is_Immediately_Visible (Scop);
end if;
- E := First_Entity (Current_Scope);
-
-- Make entities in scope visible again. For child units, restore
-- visibility only if they are actually in context.
+ E := First_Entity (Current_Scope);
while Present (E) loop
if not Is_Child_Unit (E)
or else Is_Visible_Child_Unit (E)
procedure Re_Install_Use_Clauses is
U : Node_Id;
-
begin
for J in reverse 1 .. Num_Scopes loop
U := Use_Clauses (J);
begin
Num_Scopes := Num_Scopes + 1;
Use_Clauses (Num_Scopes) :=
- Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause;
- E := First_Entity (Current_Scope);
+ Scope_Stack.Table (Scope_Stack.Last).First_Use_Clause;
+ E := First_Entity (Current_Scope);
while Present (E) loop
Set_Is_Immediately_Visible (E, False);
Next_Entity (E);
begin
if Limited_Present (N) then
+
-- Ada 2005 (AI-50217): Build visibility structures but do not
-- analyze unit
-- Instance is declared in the visible part of the wrapper package.
E_Name := First_Entity (Defining_Entity (U));
-
while Present (E_Name) loop
exit when Is_Subprogram (E_Name)
and then Is_Generic_Instance (E_Name);
Style_Check := Save_Style_Check;
Cunit_Boolean_Restrictions_Restore (Save_C_Restrict);
- -- Record the reference, but do NOT set the unit as referenced, we
- -- want to consider the unit as unreferenced if this is the only
- -- reference that occurs.
+ -- Record the reference, but do NOT set the unit as referenced, we want
+ -- to consider the unit as unreferenced if this is the only reference
+ -- that occurs.
Set_Entity_With_Style_Check (Name (N), E_Name);
Generate_Reference (E_Name, Name (N), 'w', Set_Ref => False);
if Is_Child_Unit (E_Name) then
Pref := Prefix (Name (N));
Par_Name := Scope (E_Name);
-
while Nkind (Pref) = N_Selected_Component loop
Change_Selected_Component_To_Expanded_Name (Pref);
Set_Entity_With_Style_Check (Pref, Par_Name);
Generate_Reference (Par_Name, Pref);
Pref := Prefix (Pref);
- -- If E_Name is the dummy entity for a nonexistent unit,
- -- its scope is set to Standard_Standard, and no attempt
- -- should be made to further unwind scopes.
+ -- If E_Name is the dummy entity for a nonexistent unit, its scope
+ -- is set to Standard_Standard, and no attempt should be made to
+ -- further unwind scopes.
if Par_Name /= Standard_Standard then
Par_Name := Scope (Par_Name);
if Present (Entity (Pref))
and then not Analyzed (Parent (Parent (Entity (Pref))))
then
- -- If the entity is set without its unit being compiled,
- -- the original parent is a renaming, and Par_Name is the
- -- renamed entity. For visibility purposes, we need the
- -- original entity, which must be analyzed now, because
- -- Load_Unit retrieves directly the renamed unit, and the
- -- renaming declaration itself has not been analyzed.
+ -- If the entity is set without its unit being compiled, the
+ -- original parent is a renaming, and Par_Name is the renamed
+ -- entity. For visibility purposes, we need the original entity,
+ -- which must be analyzed now because Load_Unit directly retrieves
+ -- the renamed unit, and the renaming declaration itself has not
+ -- been analyzed.
Analyze (Parent (Parent (Entity (Pref))));
pragma Assert (Renamed_Object (Entity (Pref)) = Par_Name);
end if;
-- If the withed unit is System, and a system extension pragma is
- -- present, compile the extension now, rather than waiting for
- -- a visibility check on a specific entity.
+ -- present, compile the extension now, rather than waiting for a
+ -- visibility check on a specific entity.
if Chars (E_Name) = Name_System
and then Scope (E_Name) = Standard_Standard
--------------
function In_Chain (E : Entity_Id) return Boolean is
- H : Entity_Id := Current_Entity (E);
+ H : Entity_Id;
begin
+ H := Current_Entity (E);
while Present (H) loop
-
if H = E then
return True;
else
Decl :=
First (Visible_Declarations (Specification (Unit (Cunit (Unum)))));
-
while Present (Decl) loop
-
if Nkind (Decl) = N_Full_Type_Declaration
and then Chars (Defining_Identifier (Decl)) = Chars (Sel)
then
or else Kind = N_Subprogram_Body
or else Kind = N_Task_Body
or else Kind = N_Protected_Body)
-
and then (Nkind (Parent (Par)) = N_Compilation_Unit
- or else Nkind (Parent (Par)) = N_Subunit)
+ or else Nkind (Parent (Par)) = N_Subunit)
then
null;
function Build_Unit_Name (Nam : Node_Id) return Node_Id;
+ ---------------------
+ -- Build_Unit_Name --
+ ---------------------
+
function Build_Unit_Name (Nam : Node_Id) return Node_Id is
Result : Node_Id;
end if;
end Build_Unit_Name;
+ -- Start of processing for Expand_With_Clause
+
begin
New_Nodes_OK := New_Nodes_OK + 1;
Withn :=
New_Nodes_OK := New_Nodes_OK - 1;
end Implicit_With_On_Parent;
+ --------------
+ -- In_Chain --
+ --------------
+
+ function In_Chain (E : Entity_Id) return Boolean is
+ H : Entity_Id;
+
+ begin
+ H := Current_Entity (E);
+ while Present (H) loop
+ if H = E then
+ return True;
+ else
+ H := Homonym (H);
+ end if;
+ end loop;
+
+ return False;
+ end In_Chain;
+
---------------------
-- Install_Context --
---------------------
if Nkind (Lib_Unit) = N_Package_Body
or else (Nkind (Lib_Unit) = N_Subprogram_Body
- and then not Acts_As_Spec (N))
+ and then not Acts_As_Spec (N))
then
Install_Context (Library_Unit (N));
-- context clause of the body are directly visible.
declare
- Lib_Spec : Node_Id := Unit (Library_Unit (N));
+ Lib_Spec : Node_Id;
P : Node_Id;
P_Name : Entity_Id;
begin
+ Lib_Spec := Unit (Library_Unit (N));
while Is_Child_Spec (Lib_Spec) loop
P := Unit (Parent_Spec (Lib_Spec));
-- Traverse the list of packages
Nam := First (Names (Item));
-
while Present (Nam) loop
E := Entity (Nam);
pragma Assert (Present (Parent (E)));
- if Nkind (Parent (E))
- = N_Package_Renaming_Declaration
+ if Nkind (Parent (E)) = N_Package_Renaming_Declaration
and then Renamed_Entity (E) = WEnt
then
- Error_Msg_N ("unlimited view visible through "
- & "use_clause + renamings", W);
+ Error_Msg_N ("unlimited view visible through " &
+ "use clause and renamings", W);
return;
elsif Nkind (Parent (E)) = N_Package_Specification then
end loop;
if E2 = WEnt then
- Error_Msg_N ("unlimited view visible through "
- & "use_clause ", W);
+ Error_Msg_N
+ ("unlimited view visible through use clause ", W);
return;
end if;
New_Nodes_OK := New_Nodes_OK + 1;
if Nkind (Nam) = N_Identifier then
- Withn := Make_With_Clause (Loc, Nam);
+ Withn :=
+ Make_With_Clause (Loc,
+ Name => Nam);
else pragma Assert (Nkind (Nam) = N_Selected_Component);
- Withn := Make_With_Clause (Loc,
- Make_Selected_Component (Loc,
- Prefix => Prefix (Nam),
- Selector_Name => Selector_Name (Nam)));
+ Withn :=
+ Make_With_Clause (Loc,
+ Name => Make_Selected_Component (Loc,
+ Prefix => Prefix (Nam),
+ Selector_Name => Selector_Name (Nam)));
Set_Parent (Withn, Parent (N));
end if;
Subunit => False,
Error_Node => Nam);
- if not Analyzed (Cunit (Unum)) then
- -- Do not generate a limited_with_clause on the current unit.
- -- This path is taken when a unit has a limited_with clause on
- -- one of its child units.
+ -- Do not generate a limited_with_clause on the current unit.
+ -- This path is taken when a unit has a limited_with clause on
+ -- one of its child units.
- if Unum = Current_Sem_Unit then
- return;
- end if;
+ if Unum = Current_Sem_Unit then
+ return;
+ end if;
- Set_Library_Unit (Withn, Cunit (Unum));
- Set_Corresponding_Spec
- (Withn, Specification (Unit (Cunit (Unum))));
+ Set_Library_Unit (Withn, Cunit (Unum));
+ Set_Corresponding_Spec
+ (Withn, Specification (Unit (Cunit (Unum))));
- if not Previous_Withed_Unit (Withn) then
- Prepend (Withn, Context_Items (Parent (N)));
- Mark_Rewrite_Insertion (Withn);
+ if not Previous_Withed_Unit (Withn) then
+ Prepend (Withn, Context_Items (Parent (N)));
+ Mark_Rewrite_Insertion (Withn);
- -- Add implicit limited_with_clauses for parents of child units
- -- mentioned in limited_with clauses
+ -- Add implicit limited_with_clauses for parents of child units
+ -- mentioned in limited_with clauses.
- if Nkind (Nam) = N_Selected_Component then
- Expand_Limited_With_Clause (Comp_Unit, Prefix (Nam), N);
- end if;
+ if Nkind (Nam) = N_Selected_Component then
+ Expand_Limited_With_Clause (Comp_Unit, Prefix (Nam), N);
+ end if;
- Analyze (Withn);
+ Analyze (Withn);
+
+ if not Limited_View_Installed (Withn) then
Install_Limited_Withed_Unit (Withn);
end if;
end if;
-- case it is already being compiled and it makes no sense
-- to install its limited view.
- if Library_Unit (Item) /= Cunit (Current_Sem_Unit) then
+ if Library_Unit (Item) /= Cunit (Current_Sem_Unit)
+ and then not Limited_View_Installed (Item)
+ then
Install_Limited_Withed_Unit (Item);
end if;
end if;
or else Nkind (Original_Node (Lib_Unit)) in N_Generic_Instantiation
or else
(Nkind (Lib_Unit) = N_Package_Declaration
- and then Present (Generic_Parent (Specification (Lib_Unit))))
+ and then Present (Generic_Parent (Specification (Lib_Unit))))
then
null;
else
if Nkind (Parent (Decl)) = N_Compilation_Unit then
Item := First (Context_Items (Parent (Decl)));
-
while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then Private_Present (Item)
then
if Limited_Present (Item) then
- Install_Limited_Withed_Unit (Item);
+ if not Limited_View_Installed (Item) then
+ Install_Limited_Withed_Unit (Item);
+ end if;
else
Install_Withed_Unit (Item, Private_With_OK => True);
end if;
-- scope of each entity is an ancestor of the current unit.
Item := First (Context_Items (N));
+ while Present (Item) loop
- -- Do not install private_with_clauses if the unit is a package
- -- declaration, unless it is itself a private child unit.
+ -- Do not install private_with_clauses if the unit is a package
+ -- declaration, unless it is itself a private child unit.
- while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then not Implicit_With (Item)
and then not Limited_Present (Item)
and then
(not Private_Present (Item)
- or else Nkind (Unit (N)) /= N_Package_Declaration
- or else Private_Present (N))
+ or else Nkind (Unit (N)) /= N_Package_Declaration
+ or else Private_Present (N))
then
Id := Entity (Name (Item));
begin
Clause := First (Context_Items (N));
-
while Present (Clause) loop
if Nkind (Clause) = N_With_Clause
and then Entity (Name (Clause)) = Prev
-------------------------------
procedure Install_Limited_Withed_Unit (N : Node_Id) is
- Unum : constant Unit_Number_Type :=
- Get_Source_Unit (Library_Unit (N));
P_Unit : constant Entity_Id := Unit (Library_Unit (N));
P : Entity_Id;
Is_Child_Package : Boolean := False;
- Lim_Header : Entity_Id;
- Lim_Typ : Entity_Id;
-
- function In_Chain (E : Entity_Id) return Boolean;
- -- Check that the shadow entity is not already in the homonym
- -- chain, for example through a limited_with clause in a parent unit.
+ Lim_Header : Entity_Id;
+ Lim_Typ : Entity_Id;
function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean;
-- Check if some package installed though normal with-clauses has a
-- renaming declaration of package P. AARM 10.1.2(21/2).
- --------------
- -- In_Chain --
- --------------
-
- function In_Chain (E : Entity_Id) return Boolean is
- H : Entity_Id := Current_Entity (E);
-
- begin
- while Present (H) loop
- if H = E then
- return True;
- else
- H := Homonym (H);
- end if;
- end loop;
-
- return False;
- end In_Chain;
-
----------------------------------
-- Is_Visible_Through_Renamings --
----------------------------------
function Is_Visible_Through_Renamings (P : Entity_Id) return Boolean is
- Kind : constant Node_Kind := Nkind (Unit (Cunit (Current_Sem_Unit)));
+ Kind : constant Node_Kind :=
+ Nkind (Unit (Cunit (Current_Sem_Unit)));
Aux_Unit : Node_Id;
Item : Node_Id;
Decl : Entity_Id;
-- Start of processing for Install_Limited_Withed_Unit
begin
+ pragma Assert (not Limited_View_Installed (N));
+
-- In case of limited with_clause on subprograms, generics, instances,
-- or renamings, the corresponding error was previously posted and we
-- have nothing to do here.
P := Defining_Unit_Name (Specification (P_Unit));
- if Nkind (P) = N_Defining_Program_Unit_Name then
-
- -- Retrieve entity of child package
+ -- Handle child packages
+ if Nkind (P) = N_Defining_Program_Unit_Name then
Is_Child_Package := True;
P := Defining_Identifier (P);
end if;
-- Do not install the limited-view if the full-view is already visible
- -- through some renaming declaration
+ -- through renaming declarations.
if Is_Visible_Through_Renamings (P) then
return;
-- with X; -- [2]
-- package body A is ...
- -- The compilation of A's body installs the entities of its
- -- withed packages (the context clauses found at [2]) and
- -- then the context clauses of its specification (found at [1]).
-
- -- As a consequence, at point [1] the specification of X has been
- -- analyzed and it is immediately visible. According to the semantics
- -- of the limited-with context clauses we don't install the limited
- -- view because the full view of X supersedes its limited view.
+ -- The compilation of A's body installs the context clauses found at [2]
+ -- and then the context clauses of its specification (found at [1]). As
+ -- a consequence, at [1] the specification of X has been analyzed and it
+ -- is immediately visible. According to the semantics of limited-with
+ -- context clauses we don't install the limited view because the full
+ -- view of X supersedes its limited view.
- if Analyzed (Cunit (Unum))
+ if Analyzed (P_Unit)
and then (Is_Immediately_Visible (P)
- or else (Is_Child_Package
- and then Is_Visible_Child_Unit (P)))
+ or else (Is_Child_Package
+ and then Is_Visible_Child_Unit (P)))
then
-- Ada 2005 (AI-262): Install the private declarations of P
then
declare
Id : Entity_Id;
+
begin
Id := First_Private_Entity (P);
-
while Present (Id) loop
if not Is_Internal (Id)
and then not Is_Child_Unit (Id)
Write_Eol;
end if;
- if not Analyzed (Cunit (Unum)) then
- Set_Ekind (P, E_Package);
- Set_Etype (P, Standard_Void_Type);
- Set_Scope (P, Standard_Standard);
+ -- If the unit has not been analyzed and the limited view has not been
+ -- already installed then we install it.
+
+ if not Analyzed (P_Unit) then
+ if not In_Chain (P) then
- -- Place entity on visibility structure
+ -- Minimum decoration
+
+ Set_Ekind (P, E_Package);
+ Set_Etype (P, Standard_Void_Type);
+ Set_Scope (P, Standard_Standard);
+
+ if Is_Child_Package then
+ Set_Is_Child_Unit (P);
+ Set_Is_Visible_Child_Unit (P);
+ Set_Scope (P, Defining_Entity (Unit (Parent_Spec (P_Unit))));
+ end if;
+
+ -- Place entity on visibility structure
- if Current_Entity (P) /= P then
Set_Homonym (P, Current_Entity (P));
Set_Current_Entity (P);
Write_Eol;
end if;
- end if;
+ -- Install the incomplete view. The first element of the limited
+ -- view is a header (an E_Package entity) used to reference the
+ -- first shadow entity in the private part of the package.
- if Is_Child_Package then
- Set_Is_Child_Unit (P);
- Set_Is_Visible_Child_Unit (P);
+ Lim_Header := Limited_View (P);
+ Lim_Typ := First_Entity (Lim_Header);
- declare
- Parent_Comp : Node_Id;
- Parent_Id : Entity_Id;
+ while Present (Lim_Typ)
+ and then Lim_Typ /= First_Private_Entity (Lim_Header)
+ loop
+ Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ));
+ Set_Current_Entity (Lim_Typ);
- begin
- Parent_Comp := Parent_Spec (Unit (Cunit (Unum)));
- Parent_Id := Defining_Entity (Unit (Parent_Comp));
+ if Debug_Flag_I then
+ Write_Str (" (homonym) chain ");
+ Write_Name (Chars (Lim_Typ));
+ Write_Eol;
+ end if;
- Set_Scope (P, Parent_Id);
- end;
+ Next_Entity (Lim_Typ);
+ end loop;
end if;
- else
- -- If the unit appears in a previous regular with_clause, the
- -- regular entities must be unchained before the shadow ones
- -- are made accessible.
+ -- If the unit appears in a previous regular with_clause, the regular
+ -- entities of the public part of the withed package must be replaced
+ -- by the shadow ones.
+
+ -- This code must be kept synchronized with the code that replaces the
+ -- the shadow entities by the real entities (see body of Remove_Limited
+ -- With_Clause); otherwise the contents of the homonym chains are not
+ -- consistent.
+
+ else
+ -- Hide all the type entities of the public part of the package to
+ -- avoid its usage. This is needed to cover all the subtype decla-
+ -- rations because we do not remove them from the homonym chain.
declare
- Ent : Entity_Id;
+ E : Entity_Id;
+
begin
- Ent := First_Entity (P);
+ E := First_Entity (P);
+ while Present (E) and then E /= First_Private_Entity (P) loop
+ if Is_Type (E) then
+ Set_Was_Hidden (E, Is_Hidden (E));
+ Set_Is_Hidden (E);
+ end if;
- while Present (Ent) loop
- Unchain (Ent);
- Next_Entity (Ent);
+ Next_Entity (E);
end loop;
end;
- end if;
- -- The package must be visible while the limited-with clause is active,
- -- because references to the type P.T must resolve in the usual way.
+ -- Replace the real entities by the shadow entities of the limited
+ -- view. The first element of the limited view is a header that is
+ -- used to reference the first shadow entity in the private part
+ -- of the package.
- Set_Is_Immediately_Visible (P);
+ Lim_Header := Limited_View (P);
- -- Install each incomplete view. The first element of the limited view
- -- is a header (an E_Package entity) that is used to reference the first
- -- shadow entity in the private part of the package
+ Lim_Typ := First_Entity (Lim_Header);
+ while Present (Lim_Typ)
+ and then Lim_Typ /= First_Private_Entity (Lim_Header)
+ loop
+ pragma Assert (not In_Chain (Lim_Typ));
- Lim_Header := Limited_View (P);
- Lim_Typ := First_Entity (Lim_Header);
+ -- Do not unchain child units
- while Present (Lim_Typ) loop
+ if not Is_Child_Unit (Lim_Typ) then
+ declare
+ Prev : Entity_Id;
- exit when not Private_Present (N)
- and then Lim_Typ = First_Private_Entity (Lim_Header);
+ begin
+ Set_Homonym (Lim_Typ, Homonym (Non_Limited_View (Lim_Typ)));
+ Prev := Current_Entity (Lim_Typ);
- if not In_Chain (Lim_Typ) then
- Set_Homonym (Lim_Typ, Current_Entity (Lim_Typ));
- Set_Current_Entity (Lim_Typ);
+ if Prev = Non_Limited_View (Lim_Typ) then
+ Set_Current_Entity (Lim_Typ);
+ else
+ while Present (Prev)
+ and then Homonym (Prev) /= Non_Limited_View (Lim_Typ)
+ loop
+ Prev := Homonym (Prev);
+ end loop;
- if Debug_Flag_I then
- Write_Str (" (homonym) chain ");
- Write_Name (Chars (Lim_Typ));
- Write_Eol;
+ Set_Homonym (Prev, Lim_Typ);
+ end if;
+ end;
+
+ if Debug_Flag_I then
+ Write_Str (" (homonym) chain ");
+ Write_Name (Chars (Lim_Typ));
+ Write_Eol;
+ end if;
end if;
- end if;
- Next_Entity (Lim_Typ);
- end loop;
+ Next_Entity (Lim_Typ);
+ end loop;
+ end if;
- -- The context clause has installed a limited-view, mark it
- -- accordingly, to uninstall it when the context is removed.
+ -- The package must be visible while the limited-with clause is active
+ -- because references to the type P.T must resolve in the usual way.
+ -- In addition, we remember that the limited-view has been installed to
+ -- uninstall it at the point of context removal.
+ Set_Is_Immediately_Visible (P);
Set_Limited_View_Installed (N);
Set_From_With_Type (P);
end Install_Limited_Withed_Unit;
if P /= Standard_Standard then
- -- If the unit is not analyzed after analysis of the with clause,
- -- and it is an instantiation, then it awaits a body and is the main
- -- unit. Its appearance in the context of some other unit indicates
- -- a circular dependency (DEC suite perversity).
+ -- If the unit is not analyzed after analysis of the with clause and
+ -- it is an instantiation then it awaits a body and is the main unit.
+ -- Its appearance in the context of some other unit indicates a
+ -- circular dependency (DEC suite perversity).
if not Analyzed (Uname)
and then Nkind (Parent (Uname)) = N_Package_Instantiation
elsif not Is_Visible_Child_Unit (Uname) then
Set_Is_Visible_Child_Unit (Uname);
- -- If the child unit appears in the context of its parent, it
- -- is immediately visible.
+ -- If the child unit appears in the context of its parent, it is
+ -- immediately visible.
if In_Open_Scopes (Scope (Uname)) then
Set_Is_Immediately_Visible (Uname);
(Defining_Entity (Unit (Library_Unit (With_Clause)))));
end if;
- -- The parent unit may have been installed already, and
- -- may have appeared in a use clause.
+ -- The parent unit may have been installed already, and may have
+ -- appeared in a use clause.
if In_Use (Scope (Uname)) then
Set_Is_Potentially_Use_Visible (Uname);
begin
Decl := First_Decl;
-
while Present (Decl) loop
-- For each library_package_declaration in the environment, there
if Nkind (Decl) = N_Full_Type_Declaration then
Is_Tagged :=
Nkind (Type_Definition (Decl)) = N_Record_Definition
- and then Tagged_Present (Type_Definition (Decl));
+ and then Tagged_Present (Type_Definition (Decl));
Comp_Typ := Defining_Identifier (Decl);
and then Present (Corresponding_Body (Unit_Declaration_Node (E)))
then
Ent := First_Entity (E);
-
while Present (Ent) loop
if Entity_Needs_Body (Ent) then
return True;
procedure Remove_Limited_With_Clause (N : Node_Id) is
P_Unit : constant Entity_Id := Unit (Library_Unit (N));
- P : Entity_Id := Defining_Unit_Name (Specification (P_Unit));
+ P : Entity_Id;
+ Lim_Header : Entity_Id;
Lim_Typ : Entity_Id;
+ Prev : Entity_Id;
begin
- if Nkind (P) = N_Defining_Program_Unit_Name then
+ pragma Assert (Limited_View_Installed (N));
- -- Retrieve entity of Child package
+ -- In case of limited with_clause on subprograms, generics, instances,
+ -- or renamings, the corresponding error was previously posted and we
+ -- have nothing to do here.
+
+ if Nkind (P_Unit) /= N_Package_Declaration then
+ return;
+ end if;
+
+ P := Defining_Unit_Name (Specification (P_Unit));
+ -- Handle child packages
+
+ if Nkind (P) = N_Defining_Program_Unit_Name then
P := Defining_Identifier (P);
end if;
Write_Eol;
end if;
- -- Remove all shadow entities from visibility. The first element of the
- -- limited view is a header (an E_Package entity) that is used to
- -- reference the first shadow entity in the private part of the package
-
- Lim_Typ := First_Entity (Limited_View (P));
+ -- Prepare the removal of the shadow entities from visibility. The
+ -- first element of the limited view is a header (an E_Package
+ -- entity) that is used to reference the first shadow entity in the
+ -- private part of the package
- while Present (Lim_Typ) loop
- Unchain (Lim_Typ);
- Next_Entity (Lim_Typ);
- end loop;
-
- -- Indicate that the limited view of the package is not installed
-
- Set_From_With_Type (P, False);
- Set_Limited_View_Installed (N, False);
+ Lim_Header := Limited_View (P);
+ Lim_Typ := First_Entity (Lim_Header);
- -- If the exporting package has previously been analyzed, it
- -- has appeared in the closure already and should be left alone.
- -- Otherwise, remove package itself from visibility.
+ -- Remove package and shadow entities from visibility if it has not
+ -- been analyzed
if not Analyzed (P_Unit) then
Unchain (P);
- Set_First_Entity (P, Empty);
- Set_Last_Entity (P, Empty);
- Set_Ekind (P, E_Void);
- Set_Scope (P, Empty);
Set_Is_Immediately_Visible (P, False);
- else
+ while Present (Lim_Typ) loop
+ Unchain (Lim_Typ);
+ Next_Entity (Lim_Typ);
+ end loop;
+
+ -- Otherwise this package has already appeared in the closure and its
+ -- shadow entities must be replaced by its real entities. This code
+ -- must be kept synchronized with the complementary code in Install
+ -- Limited_Withed_Unit.
- -- Reinstall visible entities (entities removed from visibility in
- -- Install_Limited_Withed to install the shadow entities).
+ else
+ -- Real entities that are type or subtype declarations were hidden
+ -- from visibility at the point of installation of the limited-view.
+ -- Now we recover the previous value of the hidden attribute.
declare
- Ent : Entity_Id;
+ E : Entity_Id;
begin
- Ent := First_Entity (P);
- while Present (Ent) and then Ent /= First_Private_Entity (P) loop
+ E := First_Entity (P);
+ 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);
+ end loop;
+ end;
- -- Shadow entities have not been added to the list of
- -- entities associated to the package spec. Therefore we
- -- just have to re-chain all its visible entities.
+ while Present (Lim_Typ)
+ and then Lim_Typ /= First_Private_Entity (Lim_Header)
+ loop
+ pragma Assert (not In_Chain (Non_Limited_View (Lim_Typ)));
- if not Is_Class_Wide_Type (Ent) then
+ -- Child units have not been unchained
- Set_Homonym (Ent, Current_Entity (Ent));
- Set_Current_Entity (Ent);
+ if not Is_Child_Unit (Non_Limited_View (Lim_Typ)) then
+ Prev := Current_Entity (Lim_Typ);
- if Debug_Flag_I then
- Write_Str (" (homonym) chain ");
- Write_Name (Chars (Ent));
- Write_Eol;
- end if;
+ if Prev = Lim_Typ then
+ Set_Current_Entity (Non_Limited_View (Lim_Typ));
+ else
+ while Present (Prev)
+ and then Homonym (Prev) /= Lim_Typ
+ loop
+ Prev := Homonym (Prev);
+ end loop;
+
+ pragma Assert (Present (Prev));
+ Set_Homonym (Prev, Non_Limited_View (Lim_Typ));
end if;
- Next_Entity (Ent);
- end loop;
- end;
+ -- We must also set the next homonym entity of the real entity
+ -- to handle the case in which the next homonym was a shadow
+ -- entity.
+
+ Set_Homonym (Non_Limited_View (Lim_Typ), Homonym (Lim_Typ));
+ end if;
+
+ Next_Entity (Lim_Typ);
+ end loop;
end if;
+
+ -- Indicate that the limited view of the package is not installed
+
+ Set_From_With_Type (P, False);
+ Set_Limited_View_Installed (N, False);
end Remove_Limited_With_Clause;
--------------------
-- visible while the parent is in scope.
E := First_Entity (P_Name);
-
while Present (E) loop
-
if Is_Child_Unit (E) then
Set_Is_Immediately_Visible (E, False);
end if;
-- If P is a child unit, remove parents as well
P := Scope (P);
-
while Present (P)
and then P /= Standard_Standard
loop
OSDN Git Service
