https://gcc.gnu.org/g:7d9296d0dfbe878598250d176e74b5732b811cff
commit r16-4679-g7d9296d0dfbe878598250d176e74b5732b811cff Author: Eric Botcazou <[email protected]> Date: Tue Oct 28 09:56:33 2025 +0100 Ada: Fix generic formal subprogram with implicit default wrongly rejected It's another issue with a formal subprogram parameter of a generic unit, whose default is specified by a box and the actual is omitted, so an implicit actual with the name of the formal is used instead and resolved in the context of the instance. The problem is that, for a child generic unit, the parent unit needs to be loaded during the instantiation, but it cannot be used to resolve implicit actuals, which must be resolved in the context of the instance. So an ad-hoc mechanism is implemented to prune references to the parent unit(s) for this resolution, but that's wrong if the parent unit was loaded at an earlier point in the context of the instance. The fix disables this ad-hoc mechanism in the case where the parent unit has not been loaded during the instantiation by propagating the boolean Parent_Installed flag through the call chain. gcc/ada/ PR ada/34511 * sem_ch12.adb (Analyze_Associations): Add Parent_Installed formal parameter and pass it in call to Analyze_One_Association. (Analyze_One_Association): Add Parent_Installed formal parameter and pass it in call to Instantiate_Formal_Subprogram. (Analyze_Formal_Package_Declaration): Pass Parent_Installed in call to Analyze_Associations. (Analyze_Package_Instantiation): Likewise. (Analyze_Subprogram_Instantiation): Likewise. (Instantiate_Formal_Subprogram): Add Parent_Installed formal parameter and prune references to the parent unit(s) only if it is true. gcc/testsuite/ * gnat.dg/specs/generic_inst4-child2.ads: New test. * gnat.dg/specs/generic_inst4.ads: New helper. * gnat.dg/specs/generic_inst4-child1.ads: Likewise. Diff: --- gcc/ada/sem_ch12.adb | 106 +++++++++++++-------- .../gnat.dg/specs/generic_inst4-child1.ads | 6 ++ .../gnat.dg/specs/generic_inst4-child2.ads | 5 + gcc/testsuite/gnat.dg/specs/generic_inst4.ads | 5 + 4 files changed, 80 insertions(+), 42 deletions(-) diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 24d276ba48ae..9a155b9b4810 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -480,14 +480,16 @@ package body Sem_Ch12 is -- Create a new access type with the given designated type function Analyze_Associations - (N : Node_Id; - Formals : List_Id; - F_Copy : List_Id) return List_Id; + (N : Node_Id; + Formals : List_Id; + F_Copy : List_Id; + Parent_Installed : Boolean) return List_Id; -- At instantiation time, build the list of associations between formals -- and actuals. Each association becomes a renaming declaration for the -- formal entity. N is the instantiation node. Formals is the list of - -- unanalyzed formals. F_Copy is the analyzed list of formals in the - -- generic copy. + -- unanalyzed formals. F_Copy is the list of analyzed formals in the + -- generic copy. Parent_Installed is True if the parent has been installed + -- during the instantiation. procedure Analyze_Subprogram_Instantiation (N : Node_Id; @@ -838,9 +840,12 @@ package body Sem_Ch12 is -- the same list it is passing to Actual_Decls. function Instantiate_Formal_Subprogram - (Formal : Node_Id; - Actual : Node_Id; - Analyzed_Formal : Node_Id) return Node_Id; + (Formal : Node_Id; + Actual : Node_Id; + Analyzed_Formal : Node_Id; + Parent_Installed : Boolean) return Node_Id; + -- Parent_Installed is True if the parent has been installed during the + -- instantiation. function Instantiate_Formal_Package (Formal : Node_Id; @@ -1283,12 +1288,14 @@ package body Sem_Ch12 is procedure Analyze_One_Association (N : Node_Id; Assoc : Associations.Assoc_Rec; + Parent_Installed : Boolean; Result_Renamings : List_Id; Default_Actuals : List_Id; Actuals_To_Freeze : Elist_Id); - -- Called by Analyze_Associations for each association. The renamings - -- are appended onto Result_Renamings. Defaulted actuals are appended - -- onto Default_Actuals, and actuals that require freezing are + -- Called by Analyze_Associations for each association. Parent_Installed + -- is True if the parent has been installed during the instantiation. The + -- renamings are appended onto Result_Renamings. The defaulted actuals are + -- appended onto Default_Actuals, and actuals that require freezing are -- appended onto Actuals_To_Freeze. procedure Analyze_Structural_Associations @@ -2362,9 +2369,10 @@ package body Sem_Ch12 is -------------------------- function Analyze_Associations - (N : Node_Id; - Formals : List_Id; - F_Copy : List_Id) return List_Id + (N : Node_Id; + Formals : List_Id; + F_Copy : List_Id; + Parent_Installed : Boolean) return List_Id is use Associations; @@ -2412,6 +2420,7 @@ package body Sem_Ch12 is Analyze_One_Association (N, Assoc, + Parent_Installed, Result_Renamings, Default_Actuals, Actuals_To_Freeze); @@ -2470,6 +2479,7 @@ package body Sem_Ch12 is procedure Analyze_One_Association (N : Node_Id; Assoc : Associations.Assoc_Rec; + Parent_Installed : Boolean; Result_Renamings : List_Id; Default_Actuals : List_Id; Actuals_To_Freeze : Elist_Id) @@ -2736,7 +2746,10 @@ package body Sem_Ch12 is else Append_To (Result_Renamings, Instantiate_Formal_Subprogram - (Assoc.Un_Formal, Match, Assoc.An_Formal)); + (Assoc.Un_Formal, + Match, + Assoc.An_Formal, + Parent_Installed)); -- If formal subprogram has contracts, create wrappers -- for it. This is an expansion activity that cannot @@ -3557,7 +3570,7 @@ package body Sem_Ch12 is -- List of primitives made temporarily visible in the instantiation -- to match the visibility of the formal type. - function Build_Local_Package return Node_Id; + function Build_Local_Package (Parent_Installed : Boolean) return Node_Id; -- The formal package is rewritten so that its parameters are replaced -- with corresponding declarations. For parameters with bona fide -- associations these declarations are created by Analyze_Associations @@ -3569,7 +3582,8 @@ package body Sem_Ch12 is -- Build_Local_Package -- ------------------------- - function Build_Local_Package return Node_Id is + function Build_Local_Package (Parent_Installed : Boolean) return Node_Id + is Decls : List_Id; Pack_Decl : Node_Id; @@ -3645,9 +3659,10 @@ package body Sem_Ch12 is Decls := Analyze_Associations - (N => Original_Node (N), - Formals => Generic_Formal_Declarations (Act_Tree), - F_Copy => Generic_Formal_Declarations (Gen_Decl)); + (N => Original_Node (N), + Formals => Generic_Formal_Declarations (Act_Tree), + F_Copy => Generic_Formal_Declarations (Gen_Decl), + Parent_Installed => Parent_Installed); Vis_Prims_List := Check_Hidden_Primitives (Decls); end; @@ -3782,7 +3797,7 @@ package body Sem_Ch12 is -- internal declarations. begin - New_N := Build_Local_Package; + New_N := Build_Local_Package (Parent_Installed); -- If there are errors in the parameter list, Analyze_Associations -- raises Instantiation_Error. Patch the declaration to prevent further @@ -5159,9 +5174,10 @@ package body Sem_Ch12 is Renamings := Analyze_Associations - (N => N, - Formals => Generic_Formal_Declarations (Act_Tree), - F_Copy => Generic_Formal_Declarations (Gen_Decl)); + (N => N, + Formals => Generic_Formal_Declarations (Act_Tree), + F_Copy => Generic_Formal_Declarations (Gen_Decl), + Parent_Installed => Parent_Installed); -- Bail out if the instantiation has been turned into something else @@ -6981,9 +6997,10 @@ package body Sem_Ch12 is Renamings := Analyze_Associations - (N => N, - Formals => Generic_Formal_Declarations (Act_Tree), - F_Copy => Generic_Formal_Declarations (Gen_Decl)); + (N => N, + Formals => Generic_Formal_Declarations (Act_Tree), + F_Copy => Generic_Formal_Declarations (Gen_Decl), + Parent_Installed => Parent_Installed); -- Bail out if the instantiation has been turned into something else @@ -12538,9 +12555,10 @@ package body Sem_Ch12 is ----------------------------------- function Instantiate_Formal_Subprogram - (Formal : Node_Id; - Actual : Node_Id; - Analyzed_Formal : Node_Id) return Node_Id + (Formal : Node_Id; + Actual : Node_Id; + Analyzed_Formal : Node_Id; + Parent_Installed : Boolean) return Node_Id is Analyzed_S : constant Entity_Id := Defining_Unit_Name (Specification (Analyzed_Formal)); @@ -12548,13 +12566,7 @@ package body Sem_Ch12 is Defining_Unit_Name (Specification (Formal)); function From_Parent_Scope (Subp : Entity_Id) return Boolean; - -- If the generic is a child unit, the parent has been installed on the - -- scope stack, but a default subprogram cannot resolve to something - -- on the parent because that parent is not really part of the visible - -- context (it is there to resolve explicit local entities). If the - -- default has resolved in this way, we remove the entity from immediate - -- visibility and analyze the node again to emit an error message or - -- find another visible candidate. + -- Return true if Subp is declared in a parent scope of Analyzed_S procedure Valid_Actual_Subprogram (Act : Node_Id); -- Perform legality check and raise exception on failure @@ -12812,21 +12824,31 @@ package body Sem_Ch12 is end if; -- Gather possible interpretations for the actual before analyzing the - -- instance. If overloaded, it will be resolved when analyzing the - -- renaming declaration. + -- instance. If the actual is overloaded, then it will be resolved when + -- the renaming declaration is analyzed. if Box_Present (Formal) and then No (Actual) then Analyze (Nam); - if Is_Child_Unit (Scope (Analyzed_S)) - and then Present (Entity (Nam)) + -- If the generic is a child unit and the parent has been installed + -- during this instantiation (as opposed to having been installed in + -- the context of the instantiation at some earlier point), a default + -- subprogram cannot resolve to something in the parent because the + -- parent is not really part of the visible context (it is there to + -- resolve explicit local entities). If the default subprogram has + -- been resolved in this way, we remove the entity from immediate + -- visibility and analyze the node again to emit an error message + -- or find another visible candidate. + + if Present (Entity (Nam)) + and then Is_Child_Unit (Scope (Analyzed_S)) + and then Parent_Installed then if not Is_Overloaded (Nam) then if From_Parent_Scope (Entity (Nam)) then Set_Is_Immediately_Visible (Entity (Nam), False); Set_Entity (Nam, Empty); Set_Etype (Nam, Empty); - Analyze (Nam); Set_Is_Immediately_Visible (Entity (Nam)); end if; diff --git a/gcc/testsuite/gnat.dg/specs/generic_inst4-child1.ads b/gcc/testsuite/gnat.dg/specs/generic_inst4-child1.ads new file mode 100644 index 000000000000..2e5d7ef2a61b --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/generic_inst4-child1.ads @@ -0,0 +1,6 @@ +generic + + with procedure Proc is <>; + +package Generic_Inst4.Child1 is +end Generic_Inst4.Child1; diff --git a/gcc/testsuite/gnat.dg/specs/generic_inst4-child2.ads b/gcc/testsuite/gnat.dg/specs/generic_inst4-child2.ads new file mode 100644 index 000000000000..c84709e60649 --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/generic_inst4-child2.ads @@ -0,0 +1,5 @@ +-- { dg-do compile } + +with Generic_Inst4.Child1; + +package Generic_Inst4.Child2 is new Generic_Inst4.Child1; diff --git a/gcc/testsuite/gnat.dg/specs/generic_inst4.ads b/gcc/testsuite/gnat.dg/specs/generic_inst4.ads new file mode 100644 index 000000000000..01e4ad4bf6ef --- /dev/null +++ b/gcc/testsuite/gnat.dg/specs/generic_inst4.ads @@ -0,0 +1,5 @@ +package Generic_Inst4 is + + procedure Proc is null; + +end Generic_Inst4;
