From 9c3beb701035cb6761cbc3a63827ce6487759151 Mon Sep 17 00:00:00 2001 From: charlet Date: Mon, 5 Sep 2005 07:58:52 +0000 Subject: [PATCH] 2005-09-01 Javier Miranda Ed Schonberg * sem_ch10.adb (In_Chain): Moved from the scope of a subprogram to become local to the whole package. (Install_Limited_Withed_Unit): Instead of unchaining real entities if the package was already analyzed the new algorithm "replaces" the real entities by the shadow ones. This is required to ensure that the order of these entities in the homonym chains does not change; otherwise we can have undefined references at linking time because in case of conflicts the external name of the entities will have a suffix that depends on the order of the entities in the chain. (Remove_Limited_With_Clause): Complementary code that completes the new algorithm and replaces the shadow entities by the real ones. (Install_Limited_Withed_Unit): When unchaining entities before the installation of the shadow entities, only regular entities of the public part must be taken into account. This is required to keep this routine in synch with the work done by Remove_Limited_ With_Clause (Install_Limited_With_Clause): Introduce implicit limited_with_clause even if unit is analyzed, because the analysis of the unit is idempotent in any case, and the limited view of the unit may have to be installed for proper visibility. (Expand_Limited_With_Clause): Even if the unit in the implicit with_clause has been analyzed already, a limited view of the package must be built for the current context, if it does not exist yet. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@103878 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/sem_ch10.adb | 564 +++++++++++++++++++++++++++++---------------------- 1 file changed, 316 insertions(+), 248 deletions(-) diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index a352efd..b752eb4 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -115,6 +115,10 @@ package body Sem_Ch10 is -- 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. @@ -811,7 +815,6 @@ package body Sem_Ch10 is 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) @@ -853,14 +856,11 @@ package body Sem_Ch10 is 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); @@ -1329,7 +1329,6 @@ package body Sem_Ch10 is or else Nkind (Parent (N)) = N_Subprogram_Body then Decl := First (Declarations (Parent (N))); - while Present (Decl) and then Decl /= N loop @@ -1417,20 +1416,18 @@ package body Sem_Ch10 is 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); @@ -1444,7 +1441,6 @@ package body Sem_Ch10 is elsif Nkind (Item) = N_Use_Package_Clause then Nam := First (Names (Item)); - while Present (Nam) loop Analyze (Nam); Next (Nam); @@ -1452,7 +1448,6 @@ package body Sem_Ch10 is elsif Nkind (Item) = N_Use_Type_Clause then Nam := First (Subtype_Marks (Item)); - while Present (Nam) loop Analyze (Nam); Next (Nam); @@ -1462,22 +1457,18 @@ package body Sem_Ch10 is 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); @@ -1491,7 +1482,6 @@ package body Sem_Ch10 is Next (Item); end loop; - end Analyze_Subunit_Context; ------------------------ @@ -1521,11 +1511,10 @@ package body Sem_Ch10 is 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) @@ -1552,7 +1541,6 @@ package body Sem_Ch10 is procedure Re_Install_Use_Clauses is U : Node_Id; - begin for J in reverse 1 .. Num_Scopes loop U := Use_Clauses (J); @@ -1571,9 +1559,9 @@ package body Sem_Ch10 is 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); @@ -1741,6 +1729,7 @@ package body Sem_Ch10 is begin if Limited_Present (N) then + -- Ada 2005 (AI-50217): Build visibility structures but do not -- analyze unit @@ -1862,7 +1851,6 @@ package body Sem_Ch10 is -- 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); @@ -1899,9 +1887,9 @@ package body Sem_Ch10 is 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); @@ -1909,7 +1897,6 @@ package body Sem_Ch10 is 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); @@ -1917,9 +1904,9 @@ package body Sem_Ch10 is 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); @@ -1929,12 +1916,12 @@ package body Sem_Ch10 is 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); @@ -1946,8 +1933,8 @@ package body Sem_Ch10 is 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 @@ -2033,11 +2020,11 @@ package body Sem_Ch10 is -------------- 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 @@ -2176,9 +2163,7 @@ package body Sem_Ch10 is 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 @@ -2475,9 +2460,8 @@ package body Sem_Ch10 is 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; @@ -2504,6 +2488,10 @@ package body Sem_Ch10 is 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; @@ -2522,6 +2510,8 @@ package body Sem_Ch10 is end if; end Build_Unit_Name; + -- Start of processing for Expand_With_Clause + begin New_Nodes_OK := New_Nodes_OK + 1; Withn := @@ -2672,6 +2662,26 @@ package body Sem_Ch10 is 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 -- --------------------- @@ -2869,7 +2879,7 @@ package body Sem_Ch10 is 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)); @@ -2884,11 +2894,12 @@ package body Sem_Ch10 is -- 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)); @@ -3000,18 +3011,16 @@ package body Sem_Ch10 is -- 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 @@ -3026,8 +3035,8 @@ package body Sem_Ch10 is 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; @@ -3139,13 +3148,16 @@ package body Sem_Ch10 is 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; @@ -3160,31 +3172,32 @@ package body Sem_Ch10 is 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; @@ -3220,7 +3233,9 @@ package body Sem_Ch10 is -- 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; @@ -3277,7 +3292,7 @@ package body Sem_Ch10 is 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 @@ -3362,13 +3377,14 @@ package body Sem_Ch10 is 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; @@ -3392,18 +3408,18 @@ package body Sem_Ch10 is -- 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)); @@ -3426,7 +3442,6 @@ package body Sem_Ch10 is begin Clause := First (Context_Items (N)); - while Present (Clause) loop if Nkind (Clause) = N_With_Clause and then Entity (Name (Clause)) = Prev @@ -3462,48 +3477,24 @@ package body Sem_Ch10 is ------------------------------- 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; @@ -3589,6 +3580,8 @@ package body Sem_Ch10 is -- 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. @@ -3599,16 +3592,15 @@ package body Sem_Ch10 is 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; @@ -3624,19 +3616,17 @@ package body Sem_Ch10 is -- 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 @@ -3645,9 +3635,9 @@ package body Sem_Ch10 is 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) @@ -3676,14 +3666,26 @@ package body Sem_Ch10 is 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); @@ -3693,75 +3695,111 @@ package body Sem_Ch10 is 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; @@ -3815,10 +3853,10 @@ package body Sem_Ch10 is 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 @@ -3829,8 +3867,8 @@ package body Sem_Ch10 is 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); @@ -3847,8 +3885,8 @@ package body Sem_Ch10 is (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); @@ -4175,7 +4213,6 @@ package body Sem_Ch10 is begin Decl := First_Decl; - while Present (Decl) loop -- For each library_package_declaration in the environment, there @@ -4195,7 +4232,7 @@ package body Sem_Ch10 is 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); @@ -4458,7 +4495,6 @@ package body Sem_Ch10 is 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; @@ -4607,14 +4643,27 @@ package body Sem_Ch10 is 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; @@ -4625,66 +4674,88 @@ package body Sem_Ch10 is 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; -------------------- @@ -4721,9 +4792,7 @@ package body Sem_Ch10 is -- 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; @@ -4821,7 +4890,6 @@ package body Sem_Ch10 is -- If P is a child unit, remove parents as well P := Scope (P); - while Present (P) and then P /= Standard_Standard loop -- 2.7.4