From: Eric Botcazou Date: Tue, 31 Mar 2026 07:50:11 +0000 (+0200) Subject: Ada: Fix compiler crash on nested reduce attribute X-Git-Tag: basepoints/gcc-17~450 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=bf6989de8174c5d49ccdfc4948e1c095cc13dcf2;p=thirdparty%2Fgcc.git Ada: Fix compiler crash on nested reduce attribute This plugs a loophole in the resolution of reduction expressions, which currently cannot be resolved when their immediate context is ambiguous, for example in the case of a reduction expression nested in another one. gcc/ada/ * sem_attr.adb (Analyze_Attribute) : Rewrite the analysis of a non-overloaded reducer. Moreover, when both actuals are overloaded, compute the set of possible interpretations. (Resolve_Attribute) : Streamline the processing. gcc/testsuite/ * gnat.dg/reduce6.adb: New test. --- diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 161e5cd16c0..e4fc782fcd9 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -6221,70 +6221,152 @@ package body Sem_Attr is -- Reduce -- ------------ - when Attribute_Reduce => - Check_E2; - Error_Msg_Ada_2022_Feature ("Reduce attribute", Sloc (N)); + when Attribute_Reduce => Reduce : declare + function Is_Reducer_Subprogram (E : Entity_Id) return Boolean; + -- Return whether E is a reducer subprogram (RM 4.5.10(11-13)) + + --------------------------- + -- Is_Reducer_Subprogram -- + --------------------------- + + function Is_Reducer_Subprogram (E : Entity_Id) return Boolean is + F1, F2 : Entity_Id; - declare - Stream : constant Node_Id := Prefix (N); - Typ : Entity_Id; begin - if Nkind (Stream) /= N_Aggregate then - -- Prefix is a name, as for other attributes. + if not Can_Have_Formals (E) then + return False; + end if; - -- If the object is a function we asume that it is not - -- overloaded. AI12-242 does not suggest a name resolution - -- rule for that case, but we can suppose that the expected - -- type of the reduction is the expected type of the component - -- of the prefix. + F1 := First_Formal (E); + if No (F1) then + return False; + end if; - Analyze_And_Resolve (Stream); - Typ := Etype (Stream); + F2 := Next_Formal (F1); + if No (F2) or else Present (Next_Formal (F2)) then + return False; + end if; - -- Verify that prefix can be iterated upon. + if Ekind (E) = E_Procedure then + return Ekind (F1) = E_In_Out_Parameter + and then Ekind (F2) = E_In_Parameter; + else + return Etype (E) = Etype (F1); + end if; + end Is_Reducer_Subprogram; - if Is_Array_Type (Typ) - or else Has_Aspect (Typ, Aspect_Default_Iterator) - or else Has_Aspect (Typ, Aspect_Iterable) - then - null; - else - Error_Msg_NE - ("cannot apply Reduce to object of type&", N, Typ); - end if; + -- Local variables + + I1, I2 : Interp_Index; + It1, It2 : Interp; + + -- Start of processing for Reduce + + begin + Error_Msg_Ada_2022_Feature ("Reduce attribute", Sloc (N)); + Check_E2; + + if Nkind (P) /= N_Aggregate then + -- Prefix is a name, as for other attributes + + -- If the object is a function, we assume that it is not + -- overloaded. AI12-242 does not suggest a name resolution + -- rule for that case, but we can suppose that the expected + -- type of the reduction is the expected type of the component + -- of the prefix. + + Analyze_And_Resolve (P); + P_Type := Etype (P); - elsif Present (Expressions (Stream)) - or else No (Component_Associations (Stream)) - or else Nkind (First (Component_Associations (Stream))) /= - N_Iterated_Component_Association + -- Verify that prefix can be iterated upon + + if Is_Array_Type (P_Type) + or else Has_Aspect (P_Type, Aspect_Default_Iterator) + or else Has_Aspect (P_Type, Aspect_Iterable) then - Error_Msg_N - ("prefix of Reduce must be an iterated component", N); + null; + else + Error_Msg_NE + ("cannot apply Reduce to object of type&", N, P_Type); end if; - Analyze (E1); - Analyze (E2); + elsif Present (Expressions (P)) + or else No (Component_Associations (P)) + or else Nkind (First (Component_Associations (P))) /= + N_Iterated_Component_Association + then + Error_Msg_N + ("prefix of Reduce must be an iterated component", N); + end if; - -- The type of the reduction is quickly resolved if it can be - -- inferred definitely from its actuals. In case the reduction is - -- not the rhs of an assignment, its type may be used before the - -- attribute resolution and thus crash the compiler; so we try to - -- resolve it here as much as possible. + Analyze (E1); + Analyze (E2); + + -- If either actual of the attribute is not overloaded, then it + -- determines the Accum_Subtype and, therefore, the Etype of N. - -- Note a crash may still occur if both E1 and E2 are overloaded - -- and the reduction is not the rhs of an assignment ??? + if not Is_Overloaded (E2) then + Set_Etype (N, Etype (E2)); - if not Is_Overloaded (E2) then - Set_Etype (N, Etype (E2)); + elsif not Is_Overloaded (E1) then + if Nkind (E1) = N_Attribute_Reference then + if Attribute_Name (E1) in Name_Max | Name_Min then + Set_Etype (N, Etype (E1)); + else + Error_Msg_N ("only Min and Max attributes are allowed " & + "as reducers", E1); + end if; - elsif not Is_Overloaded (E1) - and then E1 in N_Entity_Id - and then Present (First_Formal (E1)) - and then Present (Next_Formal (First_Formal (E1))) + elsif not Is_Entity_Name (E1) + or else not Is_Reducer_Subprogram (Entity (E1)) then - Set_Etype (N, Etype (Next_Formal (First_Formal (E1)))); + Error_Msg_N ("reducer must be a subprogram, an operator, " & + "or an attribute", E1); + + -- If the reducer has no entity, but the initial expression + -- does, then they have most likely been swapped. + + if Nkind (E2) = N_Attribute_Reference + or else Is_Entity_Name (E2) + then + Error_Msg_N ("\\possible swap of reducer and initial " & + "value!", E1); + end if; + + else + Set_Etype (N, Etype (First_Formal (Entity (E1)))); end if; - end; + + -- Otherwise compute the set of possible interpretations. Note that + -- we do not take into account the expression of the iterated element + -- association, if any, in the computation, which may result in too + -- large a set and, therefore, in a spurious ambiguity if the outer + -- context is not sufficient to disambiguate, but the probability of + -- this occuring in real code is very low. + + else + Set_Etype (N, Any_Type); + + Get_First_Interp (E2, I2, It2); + + while Present (It2.Nam) loop + Get_First_Interp (E1, I1, It1); + + while Present (It1.Nam) loop + if Is_Reducer_Subprogram (It1.Nam) + and then Base_Type (It2.Typ) = + Base_Type (Etype (First_Formal (It1.Nam))) + then + Add_One_Interp (N, It2.Typ, It2.Typ); + end if; + + Get_Next_Interp (I1, It1); + end loop; + + Get_Next_Interp (I2, It2); + end loop; + end if; + end Reduce; ---------- -- Read -- @@ -12784,28 +12866,22 @@ package body Sem_Attr is when Attribute_Reduce => declare - Reducer_N : constant Node_Id := First (Expressions (N)); - Reducer_E : Entity_Id; - + Reducer_N : constant Node_Id := First (Expressions (N)); Init_Value_Expr : constant Node_Id := Next (Reducer_N); - Accum_Typ : Entity_Id := Typ; - Value_Typ : Entity_Id := Empty; + + Accum_Typ : Entity_Id := Typ; function Get_Value_Subtype return Entity_Id; -- If non-ambiguous, this function sets the reducer's entity -- and returns the value subtype of the expression inside the -- array aggregate. - function Is_Reducer_Subprogram - (E : Entity_Id; - Check_Value_Subtype : Boolean := True) return Boolean; - -- This function checks whether E is a proper reducer - -- subprogram. If Check_Value_Subtype is true then the second - -- formal of E is matched against Value_Typ. + function Is_Reducer_Subprogram (E : Entity_Id) return Boolean; + -- Return whether E is a reducer subprogram (RM 4.5.10(11-13)) function Make_Array_Type (Index, Value : Entity_Id) return Entity_Id; - -- This function returs a simple array type to resolve the + -- This function returns a simple array type to resolve the -- array aggregate. ----------------------- @@ -12813,11 +12889,6 @@ package body Sem_Attr is ----------------------- function Get_Value_Subtype return Entity_Id is - Loop_Var, Init_Var : Entity_Id; - Reducer_Call, Copy_Aggr_Expr : Node_Id; - Copy_Reducer_N : constant Node_Id := - Copy_Separate_Tree (Reducer_N); - procedure Error_Mixed_Function_Procedure_Reducers; -- This procedure emits an error message with all possible -- interpretations of the reducer subprogram when there is @@ -12842,12 +12913,11 @@ package body Sem_Attr is First_Time : Boolean := True; I : Interp_Index; It : Interp; + begin Get_First_Interp (Reducer_N, I, It); while Present (It.Nam) loop - if Is_Reducer_Subprogram (It.Nam, - Check_Value_Subtype => False) - then + if Is_Reducer_Subprogram (It.Nam) then -- It may be the case that no interpretation -- matches the proper reducer profile, in this case -- we avoid emitting the error here. @@ -12896,9 +12966,7 @@ package body Sem_Attr is Get_First_Interp (Reducer_N, I, It); while Present (It.Nam) loop - if Is_Reducer_Subprogram (It.Nam, - Check_Value_Subtype => False) - then + if Is_Reducer_Subprogram (It.Nam) then case Kind is -- First matching interpretation sets the kind when E_Void => @@ -12934,6 +13002,15 @@ package body Sem_Attr is return Kind; end Reducer_Call_Statement_Kind; + -- Local variables + + Copy_Reducer_N : constant Node_Id := + Copy_Separate_Tree (Reducer_N); + + Copy_Aggr_Expr : Node_Id; + Loop_Var : Entity_Id; + Reducer_Call : Node_Id; + -- Start of processing for Get_Value_Subtype begin @@ -12941,9 +13018,7 @@ package body Sem_Attr is -- its second formal for the value subtype. if not Is_Overloaded (Reducer_N) then - if Is_Reducer_Subprogram (Entity (Reducer_N), - Check_Value_Subtype => False) - then + if Is_Reducer_Subprogram (Entity (Reducer_N)) then return Etype (Next_Formal (First_Formal (Entity (Reducer_N)))); @@ -12996,8 +13071,21 @@ package body Sem_Attr is -- number of formals with default expressions. declare - Dummy_Loop, Iter_Spec, Aggr_Expr : Node_Id; + Init_Var : constant Entity_Id := + Make_Temporary (Loc, 'B'); + + Aggr_Expr : Node_Id; + Dummy_Loop : Node_Id; + Init_Nam : Node_Id; + Iter_Spec : Node_Id; + begin + Set_Etype (Init_Var, Accum_Typ); + Mutate_Ekind (Init_Var, E_Variable); + + Init_Nam := Make_Identifier (Loc, Chars (Init_Var)); + Set_Entity (Init_Nam, Init_Var); + -- We start by preanalyzing the following loop to obtain -- the type of the iteration variable Loop_Var: @@ -13075,54 +13163,37 @@ package body Sem_Attr is pragma Assert (Etype (Loop_Var) /= Any_Type); Copy_Aggr_Expr := Copy_Separate_Tree (Aggr_Expr); - end; - - -- Instead of directly using the initialization expression, - -- which would require a full copy to be used in another - -- list, we just setup a variable Init_Var of the same type. - - declare - Init_E : constant Entity_Id := Make_Temporary (Loc, 'B'); - begin - Set_Etype (Init_E, Accum_Typ); - Mutate_Ekind (Init_E, E_Variable); - Init_Var := Make_Identifier (Loc, Chars (Init_E)); - Set_Entity (Init_Var, Init_E); + case Reducer_Call_Statement_Kind is + when E_Procedure => + Reducer_Call := + Make_Procedure_Call_Statement (Sloc (Reducer_N), + Name => Copy_Reducer_N, + Parameter_Associations => + New_List (Init_Nam, Copy_Aggr_Expr)); + + when E_Function | E_Operator => + Reducer_Call := + Make_Function_Call (Sloc (Reducer_N), + Name => Copy_Reducer_N, + Parameter_Associations => + New_List (Init_Nam, Copy_Aggr_Expr)); + Set_Etype (Reducer_Call, Accum_Typ); + + when others => + Error_Mixed_Function_Procedure_Reducers; + return Empty; + end case; end; - case Reducer_Call_Statement_Kind is - when E_Procedure => - Reducer_Call := - Make_Procedure_Call_Statement (Sloc (Reducer_N), - Name => Copy_Reducer_N, - Parameter_Associations => - New_List (Init_Var, Copy_Aggr_Expr)); - - when E_Function | E_Operator => - Reducer_Call := - Make_Function_Call (Sloc (Reducer_N), - Name => Copy_Reducer_N, - Parameter_Associations => - New_List (Init_Var, Copy_Aggr_Expr)); - Set_Etype (Reducer_Call, Accum_Typ); - - when others => - Error_Mixed_Function_Procedure_Reducers; - return Empty; - end case; - - -- To resolve Reducer_Call we augment the context with the - -- initialization and iteration (which may hide homonyms) - -- variables. Specifically, we need to restore the - -- visibility of the iteration variable since the analysis + -- To properly resolve Reducer_Call, we need to restore the + -- visibility of the iteration variable because the analysis -- of the dummy loop above hides it on exit. declare - Save_Homonym : constant Entity_Id := - Get_Name_Entity_Id (Chars (Loop_Var)); + Prev : constant Entity_Id := Current_Entity (Loop_Var); + begin - Set_Current_Entity (Init_Var); Set_Current_Entity (Loop_Var); Set_Is_Immediately_Visible (Loop_Var); Set_Is_Not_Self_Hidden (Loop_Var); @@ -13131,8 +13202,8 @@ package body Sem_Attr is Preanalyze_And_Resolve (Reducer_Call); Pop_Scope; - Set_Name_Entity_Id (Chars (Loop_Var), Save_Homonym); - Set_Name_Entity_Id (Chars (Init_Var), Empty); + Set_Is_Immediately_Visible (Loop_Var, False); + Set_Name_Entity_Id (Chars (Loop_Var), Prev); end; -- In case resolution failed, the error message is too @@ -13154,6 +13225,7 @@ package body Sem_Attr is Set_Entity (Reducer_N, Entity (Copy_Reducer_N)); return Etype (Copy_Aggr_Expr); end if; + return Empty; end Get_Value_Subtype; @@ -13161,25 +13233,23 @@ package body Sem_Attr is -- Is_Reducer_Subprogram -- --------------------------- - function Is_Reducer_Subprogram - (E : Entity_Id; - Check_Value_Subtype : Boolean := True) return Boolean - is + function Is_Reducer_Subprogram (E : Entity_Id) return Boolean is F1, F2 : Entity_Id; + begin + if not Can_Have_Formals (E) then + return False; + end if; + F1 := First_Formal (E); if No (F1) or else not Covers (Accum_Typ, Etype (F1)) then return False; + else F2 := Next_Formal (F1); - if No (F2) - or else Present (Next_Formal (F2)) - or else (Check_Value_Subtype - and then not Covers (Value_Typ, - Etype (F2))) - then + if No (F2) or else Present (Next_Formal (F2)) then return False; elsif Ekind (E) = E_Procedure then @@ -13263,6 +13333,13 @@ package body Sem_Attr is return Array_Type; end Make_Array_Type; + -- Local variables + + Reducer_E : Entity_Id; + Value_Typ : Entity_Id; + + -- Start of processing for Reduce + begin if Error_Posted (N) then return; @@ -13277,15 +13354,13 @@ package body Sem_Attr is Reducer_E := Reducer_N; else Error_Msg_N ("only Min and Max attributes are allowed " & - "as reducers", - Reducer_N); + "as reducers", Reducer_N); return; end if; elsif not Is_Entity_Name (Reducer_N) then Error_Msg_N ("reducer must be a subprogram, an operator, " & - "or an attribute", - Reducer_N); + "or an attribute", Reducer_N); -- If the reducer has no entity, but the initial expression -- does, then they have most likely been swapped. @@ -13294,8 +13369,7 @@ package body Sem_Attr is or else Is_Entity_Name (Init_Value_Expr) then Error_Msg_N ("\\possible swap of reducer and initial " & - "value!", - Reducer_N); + "value!", Reducer_N); end if; return; @@ -13346,9 +13420,6 @@ package body Sem_Attr is -- Otherwise, Accum_Typ is the subtype of the first formal -- of the reducer subprogram (RM 4.5.10(19/5)). - elsif Ekind (Reducer_E) = E_Operator then - Accum_Typ := Etype (Left_Opnd (Reducer_E)); - else Accum_Typ := Etype (First_Formal (Reducer_E)); end if; @@ -13380,7 +13451,6 @@ package body Sem_Attr is then declare Discard : Node_Id; - pragma Unreferenced (Discard); begin Discard := Compile_Time_Constraint_Error (Reducer_N, diff --git a/gcc/testsuite/gnat.dg/reduce6.adb b/gcc/testsuite/gnat.dg/reduce6.adb new file mode 100644 index 00000000000..89a30a6bca1 --- /dev/null +++ b/gcc/testsuite/gnat.dg/reduce6.adb @@ -0,0 +1,36 @@ +-- { dg-do compile } +-- { dg-options "-gnat2022" } + +with Ada.Text_IO; use Ada.Text_IO; + +procedure Reduce6 is + + type Rec1 is record + A : Integer; + end record; + + type Rec2 is record + A : Integer; + end record; + + function Init return Rec1 is (A => 0); + function Init return Rec2 is (A => 1000); -- unused + + function Foo (X : Integer) return Integer is (X); + function Foo (X : Integer) return Float is (0.0); -- unused + + function Reducer (X : Rec1; Y : Integer) return Rec1 is (A => X.A + Y); + function Reducer (X : Rec2; Y : Float) return Rec2 is (A => 2); -- unused + function Reducer (X : Rec2; Y : Integer) return Rec2 is (A => 3); -- unused + + function Higher (X : Rec1; Y : Rec1) return Rec1 is + (if X.A >= Y.A then X else Y); + function Higher (X : Rec1; Y : Float) return Rec1 is (X); -- unused + + R : Rec1 := + [for J in 1 .. 10 => + [for I in 1 .. J => Foo (I)]'Reduce (Reducer, Init)]' + Reduce (Higher, Init); +begin + Put_Line (R.A'Image); -- 55 +end;