From e3b69cc24f53d5502721c3358b24b1d0faf55d04 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Thu, 23 Jul 2020 05:55:16 -0400 Subject: [PATCH] [Ada] Spurious error in current instance used as formal package gcc/ada/ * sem_ch12.adb (Install_Parents_Of_Generic_Context, Remove_Parents_Of_Generic_Context): New subprograms. (Instantiate_Package_Body): Adding assertions to ensure that installed parents are properly removed. --- gcc/ada/sem_ch12.adb | 175 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 175 insertions(+) diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 4fbb6e56b68..78e84d47687 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -11683,6 +11683,7 @@ package body Sem_Ch12 is Act_Decl : constant Node_Id := Body_Info.Act_Decl; Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Decl); Act_Spec : constant Node_Id := Specification (Act_Decl); + Ctx_Parents : Elist_Id := No_Elist; Inst_Node : constant Node_Id := Body_Info.Inst_Node; Gen_Id : constant Node_Id := Name (Inst_Node); Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node); @@ -11694,6 +11695,24 @@ package body Sem_Ch12 is -- appear uninitialized. This is suspicious, unless the actual is a -- fully initialized type. + procedure Install_Parents_Of_Generic_Context (Inst_Scope : Entity_Id); + -- Inst_Scope is the scope where the instance appears within; when + -- the instance of a generic child package G1 appears within a generic + -- child package G2, this routine collects and installs the enclosing + -- packages of G2 which are not already installed in the Scopes stack. + -- For example, considering the following hierarchy of generic packages: + -- G (library level generic package) + -- G.G1 (generic child package of G) + -- G.Ga (generic child package of G) + -- G.Ga.Gb (generic child package of Ga) + -- G.Ga.Gb.G2 (generic child package of Gb) + -- ... if G2 contains an instance of G1, this routine installs Ga and Gb + -- (it does not install G because it was installed previously as part of + -- the regular installation of G1 parents done by Install_Parent) + + procedure Remove_Parents_Of_Generic_Context; + -- Reverse effect after instantiation is complete + ----------------------------- -- Check_Initialized_Types -- ----------------------------- @@ -11757,6 +11776,143 @@ package body Sem_Ch12 is end loop; end Check_Initialized_Types; + ---------------------------------------- + -- Install_Parents_Of_Generic_Context -- + ---------------------------------------- + + procedure Install_Parents_Of_Generic_Context (Inst_Scope : Entity_Id) is + procedure Install_Enclosing_Parent (P : Entity_Id); + -- Install public declarations of package P + + function In_Enclosing_Open_Scopes (S : Entity_Id) return Boolean; + -- Determine if the scope S is currently open (i.e. it appears + -- somewhere in the scope stack) or appears within the compilation + -- unit of an open scope. + + ------------------------------ + -- Install_Enclosing_Parent -- + ------------------------------ + + procedure Install_Enclosing_Parent (P : Entity_Id) is + Inst_Par : Entity_Id := P; + + begin + -- If this is a nested instance, the parent unit itself resolves + -- to a renaming of the parent instance, whose declaration we + -- need; in the common case the parent may be a generic (not an + -- instance) and appears as a formal package. + + if Present (Renamed_Entity (Inst_Par)) then + Inst_Par := Renamed_Entity (Inst_Par); + end if; + + Push_Scope (Inst_Par); + Set_Is_Immediately_Visible (Inst_Par); + Install_Visible_Declarations (Inst_Par); + end Install_Enclosing_Parent; + + ------------------------------ + -- In_Enclosing_Open_Scopes -- + ------------------------------ + + function In_Enclosing_Open_Scopes (S : Entity_Id) return Boolean is + E : Entity_Id; + E_Unit : Entity_Id; + + begin + for J in reverse 0 .. Scope_Stack.Last loop + E := Scope_Stack.Table (J).Entity; + E_Unit := Cunit_Entity (Get_Source_Unit (E)); + + if S = E or else S = E_Unit then + return True; + end if; + + -- Check Is_Active_Stack_Base to tell us when to stop, as there + -- are cases where Standard_Standard appears in the middle of + -- the active set of scopes. This affects the declaration and + -- overriding of private inherited operations in instantiations + -- of generic child units. + + exit when Scope_Stack.Table (J).Is_Active_Stack_Base; + end loop; + + return False; + end In_Enclosing_Open_Scopes; + + -- Local variables + + Actuals : constant List_Id := Generic_Associations (Inst_Node); + Elmt : Elmt_Id; + S : Entity_Id; + + -- Start of processing for Install_Parents_Of_Generic_Context + + begin + -- Check cases where no action is required + + if No (Actuals) then + return; + + elsif not Is_Child_Unit (Inst_Scope) + or else Ekind (Inst_Scope) /= E_Generic_Package + then + return; + end if; + + -- Collect context parents not previously installed + + S := Inst_Scope; + while S /= Standard_Standard + and then not In_Enclosing_Open_Scopes (S) + loop + if No (Ctx_Parents) then + Ctx_Parents := New_Elmt_List; + end if; + + Prepend_Elmt (S, Ctx_Parents); + S := Scope (S); + end loop; + + -- Install enclosing parents + + if Present (Ctx_Parents) then + Elmt := First_Elmt (Ctx_Parents); + while Present (Elmt) loop + Install_Enclosing_Parent (Node (Elmt)); + Next_Elmt (Elmt); + end loop; + end if; + end Install_Parents_Of_Generic_Context; + + --------------------------------------- + -- Remove_Parents_Of_Generic_Context -- + --------------------------------------- + + procedure Remove_Parents_Of_Generic_Context is + Elmt : Elmt_Id; + Par : Entity_Id; + + begin + if No (Ctx_Parents) then + return; + end if; + + -- Traverse Ctx_Parents in LIFO order to check the removed scopes + + Elmt := Last_Elmt (Ctx_Parents); + while Present (Elmt) loop + Par := Current_Scope; + pragma Assert (Par = Node (Elmt)); + + End_Package_Scope (Par); + Set_Is_Immediately_Visible (Par, False); + + Remove_Last_Elmt (Ctx_Parents); + Elmt := Last_Elmt (Ctx_Parents); + end loop; + end Remove_Parents_Of_Generic_Context; + -- Local variables -- The following constants capture the context prior to instantiating @@ -11784,6 +11940,11 @@ package body Sem_Ch12 is Par_Installed : Boolean := False; Par_Vis : Boolean := False; + Scope_Check_Id : Entity_Id; + Scope_Check_Last : Nat; + -- Value of Current_Scope before calls to Install_Parents; used to check + -- that scopes are correctly removed after instantiation. + Vis_Prims_List : Elist_Id := No_Elist; -- List of primitives made temporarily visible in the instantiation -- to match the visibility of the formal type. @@ -11997,6 +12158,9 @@ package body Sem_Ch12 is end loop; end; + Scope_Check_Id := Current_Scope; + Scope_Check_Last := Scope_Stack.Last; + -- If it is a child unit, make the parent instance (which is an -- instance of the parent of the generic) visible. The parent -- instance is the prefix of the name of the generic unit. @@ -12016,6 +12180,12 @@ package body Sem_Ch12 is Par_Installed := True; end if; + -- If the instantiation appears within a generic child some actual + -- parameter may be the current instance of the enclosing generic + -- parent. + + Install_Parents_Of_Generic_Context (Scope (Act_Decl_Id)); + -- If the instantiation is a library unit, and this is the main unit, -- then build the resulting compilation unit nodes for the instance. -- If this is a compilation unit but it is not the main unit, then it @@ -12064,6 +12234,8 @@ package body Sem_Ch12 is -- Remove the parent instances if they have been placed on the scope -- stack to compile the body. + Remove_Parents_Of_Generic_Context; + if Par_Installed then Remove_Parent (In_Body => True); @@ -12072,6 +12244,9 @@ package body Sem_Ch12 is Set_Is_Immediately_Visible (Par_Ent, Par_Vis); end if; + pragma Assert (Current_Scope = Scope_Check_Id); + pragma Assert (Scope_Stack.Last = Scope_Check_Last); + Restore_Hidden_Primitives (Vis_Prims_List); -- Restore the private views that were made visible when the body of -- 2.30.2