diff options
| -rw-r--r-- | gcc/ada/exp_attr.adb | 30 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 645 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 32 | ||||
| -rw-r--r-- | gcc/testsuite/gnat.dg/reduce1.adb | 3 |
4 files changed, 605 insertions, 105 deletions
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 8bf9509..29c64b7 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -6594,15 +6594,14 @@ package body Exp_Attr is E2 : constant Node_Id := Next (E1); Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N); - Accum_Typ : Entity_Id := Empty; + Accum_Typ : constant Entity_Id := Etype (N); New_Loop : Node_Id; function Build_Stat (Comp : Node_Id) return Node_Id; -- The reducer can be a function, a procedure whose first -- parameter is in-out, or an attribute that is a function, -- which (for now) can only be Min/Max. This subprogram - -- builds the corresponding computation for the generated loop - -- and retrieves the accumulator type as per RM 4.5.10(19/5). + -- builds the corresponding computation for the generated loop. ---------------- -- Build_Stat -- @@ -6613,7 +6612,6 @@ package body Exp_Attr is begin if Nkind (E1) = N_Attribute_Reference then - Accum_Typ := Base_Type (Entity (Prefix (E1))); Stat := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Bnn, Loc), Expression => Make_Attribute_Reference (Loc, @@ -6624,7 +6622,6 @@ package body Exp_Attr is Comp))); elsif Ekind (Entity (E1)) = E_Procedure then - Accum_Typ := Etype (First_Formal (Entity (E1))); Stat := Make_Procedure_Call_Statement (Loc, Name => New_Occurrence_Of (Entity (E1), Loc), Parameter_Associations => New_List ( @@ -6632,7 +6629,6 @@ package body Exp_Attr is Comp)); else - Accum_Typ := Etype (Entity (E1)); Stat := Make_Assignment_Statement (Loc, Name => New_Occurrence_Of (Bnn, Loc), Expression => Make_Function_Call (Loc, @@ -6642,28 +6638,6 @@ package body Exp_Attr is Comp))); end if; - -- Try to cope if E1 is wrong because it is an overloaded - -- subprogram that happens to be the first candidate - -- on a homonym chain, but that resolution candidate turns - -- out to be the wrong one. - -- This workaround usually gets the right type, but it can - -- yield the wrong subtype of that type. - - if Base_Type (Accum_Typ) /= Base_Type (Etype (N)) then - Accum_Typ := Etype (N); - end if; - - -- Try to cope with wrong E1 when Etype (N) doesn't help - if Is_Universal_Numeric_Type (Accum_Typ) then - if Is_Array_Type (Etype (Prefix (N))) then - Accum_Typ := Component_Type (Etype (Prefix (N))); - else - -- Further hackery can be added here when there is a - -- demonstrated need. - null; - end if; - end if; - return Stat; end Build_Stat; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 95f1466..1393363 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -6161,7 +6161,26 @@ package body Sem_Attr is Analyze (E1); Analyze (E2); - Set_Etype (N, Etype (E2)); + + -- 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. + + -- 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)); + + 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))) + then + Set_Etype (N, Etype (Next_Formal (First_Formal (E1)))); + end if; end; ---------- @@ -12701,82 +12720,447 @@ package body Sem_Attr is when Attribute_Reduce => declare - Reducer_Subp_Name : constant Node_Id := First (Expressions (N)); - Init_Value_Exp : constant Node_Id := - Next (Reducer_Subp_Name); - Op : Entity_Id := Empty; + Reducer_N : constant Node_Id := First (Expressions (N)); + Reducer_E : Entity_Id; + + Init_Value_Expr : constant Node_Id := Next (Reducer_N); + Accum_Typ : Entity_Id := Typ; + Value_Typ : Entity_Id := Empty; + + 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 Make_Array_Type + (Index, Value : Entity_Id) return Entity_Id; + -- This function returs a simple array type to resolve the + -- array aggregate. + + ----------------------- + -- Get_Value_Subtype -- + ----------------------- + + 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 + -- a mix of functions and procedures. Note that, this is + -- only a potential ambiguity but we cannot resolve it in a + -- definitive way as there is no construct that accepts both + -- functions and procedures together. + + function Reducer_Call_Statement_Kind return Entity_Kind; + -- This function returns the kind of a call statement able + -- to contain a reducer call. If all the candidate + -- interpretation subprograms that can be reducers agree on + -- the same subprogram type, meaning that they are all + -- procedures or all function/operators, then this function + -- returns either E_Procedure or E_Function respectively. + + --------------------------------------------- + -- Error_Mixed_Function_Procedure_Reducers -- + --------------------------------------------- + + procedure Error_Mixed_Function_Procedure_Reducers 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 + -- It may be the case that no interpretation + -- matches the proper reducer profile, in this case + -- we avoid emitting the error here. + + if First_Time then + Error_Msg_N + ("potential ambiguous reducer subprogram " & + "(cannot resolve&)", + Reducer_N); + First_Time := False; + end if; - Index : Interp_Index; - It : Interp; + if Ekind (It.Nam) = E_Function then + Error_Msg_Sloc := Sloc (It.Nam); + Error_Msg_N + ("\\possible function interpretation#!", + Reducer_N); + else + Error_Msg_Sloc := Sloc (It.Nam); + Error_Msg_N + ("\\possible procedure interpretation#!", + Reducer_N); + end if; + end if; + Get_Next_Interp (I, It); + end loop; + + if First_Time then + Error_Msg_N ("no suitable reducer subprogram found", + Reducer_N); + end if; + end Error_Mixed_Function_Procedure_Reducers; + + --------------------------------- + -- Reducer_Call_Statement_Kind -- + --------------------------------- + + function Reducer_Call_Statement_Kind return Entity_Kind is + Kind : Entity_Kind := E_Void; + I : Interp_Index; + It : Interp; + begin + if not Is_Overloaded (Reducer_N) then + return Ekind (Entity (Reducer_N)); + end if; + + Get_First_Interp (Reducer_N, I, It); + while Present (It.Nam) loop + if Is_Reducer_Subprogram (It.Nam, + Check_Value_Subtype => False) + then + case Kind is + -- First matching interpretation sets the kind + when E_Void => + if Ekind (It.Nam) + not in E_Procedure | E_Function | E_Operator + then + return E_Void; + end if; + Kind := Ekind (It.Nam); + + -- Subsequent matching interpretations must + -- agree on the same kind. + when E_Procedure => + if Ekind (It.Nam) /= E_Procedure then + return E_Void; + end if; + + -- Functions and Operators match the same call + -- statement. + when E_Function | E_Operator => + if Ekind (It.Nam) + not in E_Function | E_Operator + then + return E_Void; + end if; + + when others => + return E_Void; + end case; + end if; + Get_Next_Interp (I, It); + end loop; + return Kind; + end Reducer_Call_Statement_Kind; + + -- Start of processing for Get_Value_Subtype + + begin + -- In case the reducer is not overloaded, check directly + -- 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 + return Etype (Next_Formal + (First_Formal (Entity (Reducer_N)))); + + -- Return any type to signal the caller that no proper + -- reducer subprogram was found. + + else + return Any_Type; + end if; + end if; + + -- RM 4.5.10(11/5): the reducer subprogram is required to be + -- subtype conformant with one of the following profiles: + + -- function Reducer + -- (Accum : Accum_Subtype; + -- Value : Value_Subtype) return Accum_Subtype; + + -- Or + + -- procedure Reducer + -- (Accum : in out Accum_Subtype; + -- Value : in Value_Subtype); + + -- The Value_Subtype is the type of the expression of the + -- array aggregate, or its equivalent expansion in case of P + -- being an iterable container. Thus, given the expression N + -- as: + + -- [for I in|of It => Expr (I)]'Reduce (Reducer, Init); + + -- To find whether there are no suitable interpretations, or + -- too many, for the combination of reducer and expression + -- we resolve the following call: + + -- Reducer (Init_Var, Expr (I)) + + -- Where the context is augmented with the iteration + -- variable I of the right type, and Init_Var of type + -- Accum_Subtype. If the Reducer has both procedure and + -- function interpretations with the proper reducer profile + -- an ambiguity error is emitted. Note that, this could be a + -- false positive as the two may coexist without ambiguity + -- but a more complex resolution is needed for that. + + -- If the call above resolves correctly, we have a single, + -- non-ambiguous, reduction expression. Note that, we still + -- need to check whether Reducer has a subtype conformant + -- profile, eg. the resolved reducer may have a different + -- number of formals with default expressions. + + declare + Dummy_Loop, Iter_Spec, Aggr_Expr : Node_Id; + begin + -- We start by preanalyzing the following loop to obtain + -- the type of the iteration variable Loop_Var: + + -- for I in|of It loop + -- null; + -- end loop; + + if Nkind (P) = N_Aggregate then + declare + Stream, Stream_It : Node_Id; + begin + Stream := First (Component_Associations (P)); + Stream_It := Iterator_Specification (Stream); + Aggr_Expr := Expression (Stream); + + -- Case [for I of It => Aggr_Expr] + + if Nkind (Stream) = N_Iterated_Component_Association + and then Present (Stream_It) + and then Of_Present (Stream_It) + then + Iter_Spec := + Make_Iteration_Scheme (Loc, + Iterator_Specification => + Relocate_Node (Stream_It)); + Loop_Var := + Defining_Identifier + (Iterator_Specification (Iter_Spec)); + + -- Case [for I in Range => Aggr_Expr] + + else + Iter_Spec := + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => + Defining_Identifier + (Copy_Separate_Tree (Stream)), + Discrete_Subtype_Definition => + Relocate_Node (First (Discrete_Choices + (Stream))))); + Loop_Var := + Defining_Identifier + (Loop_Parameter_Specification (Iter_Spec)); + end if; + end; + + -- Case of prefix name + + else + Loop_Var := Make_Temporary (Loc, 'I'); + Aggr_Expr := Make_Identifier (Loc, Chars (Loop_Var)); + Iter_Spec := Make_Iteration_Scheme (Loc, + Iterator_Specification => + Make_Iterator_Specification (Loc, + Defining_Identifier => Loop_Var, + Of_Present => True, + Name => P)); + end if; + + Dummy_Loop := Make_Loop_Statement (Loc, + Iteration_Scheme => Iter_Spec); + Preanalyze (Dummy_Loop); - function Proper_Op - (Op : Entity_Id; - Strict : Boolean := False) return Boolean; - -- Is Op a suitable reducer subprogram? - -- Strict indicates whether ops found in Standard should be - -- considered even if Typ is not a predefined type. + -- The preanalysis of the loop sets the type of the + -- iteration variable. It may happen that another loop + -- variable is created in the preanalysis, in case the + -- right one is found at its next entity. - --------------- - -- Proper_Op -- - --------------- + if Etype (Loop_Var) = Any_Type then + Loop_Var := Next_Entity (Loop_Var); + end if; + pragma Assert (Present (Etype (Loop_Var))); + 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); + 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 + -- of the dummy loop above hides it on exit. + + declare + Save_Homonym : constant Entity_Id := + Get_Name_Entity_Id (Chars (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); + + Push_Scope (Scope (Loop_Var)); + Preanalyze_And_Resolve (Reducer_Call); + Pop_Scope; + + Set_Name_Entity_Id (Chars (Loop_Var), Save_Homonym); + Set_Name_Entity_Id (Chars (Init_Var), Empty); + end; + + -- In case resolution failed, the error message is too + -- generic and can be improved with additional context. + + if Error_Posted (Reducer_Call) then + Error_Msg_N ("\\no suitable reducer subprogram found", + Reducer_Call); + + -- Resolution succeeded so far - function Proper_Op - (Op : Entity_Id; - Strict : Boolean := False) return Boolean + elsif not Is_Overloaded (Reducer_Call) then + pragma Assert (Present (Entity (Copy_Reducer_N))); + pragma Assert (Present (Etype (Copy_Aggr_Expr))); + + -- Set the correct reducer entity and then return the + -- value subtype. + + Set_Entity (Reducer_N, Entity (Copy_Reducer_N)); + return Etype (Copy_Aggr_Expr); + end if; + return Empty; + end Get_Value_Subtype; + + --------------------------- + -- Is_Reducer_Subprogram -- + --------------------------- + + function Is_Reducer_Subprogram + (E : Entity_Id; + Check_Value_Subtype : Boolean := True) return Boolean is F1, F2 : Entity_Id; begin - F1 := First_Formal (Op); - if No (F1) then + 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 return False; - elsif Ekind (Op) = E_Procedure then + elsif Ekind (E) = E_Procedure then return Ekind (F1) = E_In_Out_Parameter - and then Covers (Typ, Etype (F1)); + and then Ekind (F2) = E_In_Parameter; - elsif Covers (Typ, Etype (Op)) then + elsif Covers (Accum_Typ, Etype (E)) then return True; - elsif Ekind (Op) = E_Operator - and then Scope (Op) = Standard_Standard - and then not Strict + elsif Ekind (E) = E_Operator + and then Scope (E) = Standard_Standard then -- Nonassociative ops like division are unlikely to -- come up in practice, but they are legal. - case Any_Operator_Name'(Chars (Op)) is + case Any_Operator_Name'(Chars (E)) is when Name_Op_Add - | Name_Op_Subtract - | Name_Op_Multiply - | Name_Op_Divide - | Name_Op_Expon + | Name_Op_Subtract + | Name_Op_Multiply + | Name_Op_Divide + | Name_Op_Expon => - return Is_Numeric_Type (Typ); + return Is_Numeric_Type (Accum_Typ); when Name_Op_Mod | Name_Op_Rem => - return Is_Numeric_Type (Typ) - and then Is_Discrete_Type (Typ); + return Is_Numeric_Type (Accum_Typ) + and then Is_Discrete_Type (Accum_Typ); when Name_Op_And | Name_Op_Or | Name_Op_Xor => -- No Boolean array operators in Standard - return Is_Boolean_Type (Typ) - or else Is_Modular_Integer_Type (Typ); + return Is_Modular_Integer_Type (Accum_Typ) + or else Is_Boolean_Type (Accum_Typ); when Name_Op_Concat => - return Is_Array_Type (Typ) - and then Number_Dimensions (Typ) = 1; - - when Name_Op_Eq | Name_Op_Ne - | Name_Op_Lt | Name_Op_Le - | Name_Op_Gt | Name_Op_Ge + return Is_Array_Type (Accum_Typ) + and then Number_Dimensions (Accum_Typ) = 1; + + when Name_Op_Eq + | Name_Op_Ne + | Name_Op_Lt + | Name_Op_Le + | Name_Op_Gt + | Name_Op_Ge => - return Is_Boolean_Type (Typ); + return Is_Boolean_Type (Accum_Typ); when Name_Op_Abs | Name_Op_Not => -- unary ops were already handled @@ -12788,46 +13172,157 @@ package body Sem_Attr is return False; end if; end if; - end Proper_Op; + end Is_Reducer_Subprogram; - begin - -- First try to resolve the reducer and then, if this succeeds, - -- resolve the initial value. This nicely deals with confused - -- programmers who swap the two items. - - if Is_Overloaded (Reducer_Subp_Name) then - Outer : - for Retry in Boolean loop - Get_First_Interp (Reducer_Subp_Name, Index, It); - while Present (It.Nam) loop - if Proper_Op (It.Nam, Strict => not Retry) then - Op := It.Nam; - Set_Entity (Reducer_Subp_Name, Op); - exit Outer; - end if; + --------------------- + -- Make_Array_Type -- + --------------------- - Get_Next_Interp (Index, It); - end loop; - end loop Outer; + function Make_Array_Type + (Index, Value : Entity_Id) return Entity_Id + is + Array_Type : constant Entity_Id := Make_Temporary (Loc, 'A'); + Range_N : constant Node_Id := + Make_Range (Loc, + Low_Bound => Type_Low_Bound (Index), + High_Bound => Type_High_Bound (Index)); + begin + Set_In_List (Range_N); + Set_Etype (Range_N, Index); + + Set_Etype (Array_Type, Array_Type); + Set_Scope (Array_Type, Find_Enclosing_Scope (N)); + Mutate_Ekind (Array_Type, E_Array_Type); + Set_Component_Type (Array_Type, Value); + Set_First_Index (Array_Type, Range_N); + + return Array_Type; + end Make_Array_Type; + + begin + if Error_Posted (N) then + return; + end if; - elsif Nkind (Reducer_Subp_Name) = N_Attribute_Reference - and then (Attribute_Name (Reducer_Subp_Name) = Name_Max - or else Attribute_Name (Reducer_Subp_Name) = Name_Min) + -- If the Accum_Typ is an unconstrained array then a + -- Constraint_Error will be raised at runtime as most + -- computations will change its length type during the + -- reduction execution, RM 4.5.10(25/5). For instance, this is + -- the case with: [...]'Reduce ("&", ...). When the expression + -- yields non-empty strings, the reduction repeatedly executes + -- the following assignment: + -- Acc := Expr (I) & Acc; + -- which will raise a Constraint_Error since the number of + -- elements is increasing. + + if not Is_Numeric_Type (Base_Type (Accum_Typ)) + and then not Is_Constrained (Accum_Typ) then - Op := Reducer_Subp_Name; + declare + Discard : Node_Id; + pragma Unreferenced (Discard); + begin + Discard := Compile_Time_Constraint_Error + (Reducer_N, + "potential length mismatch!!??", + Accum_Typ); + return; + end; + end if; + + -- If no error has been posted and the accumulation type is + -- constrained, then the resolution of the reducer can start. + + if Nkind (Reducer_N) = N_Attribute_Reference then + if Attribute_Name (Reducer_N) in Name_Max | Name_Min then + Value_Typ := Etype (Reducer_N); + Reducer_E := Reducer_N; + else + Error_Msg_N ("only Min and Max attributes are allowed " & + "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); + + -- If the reducer has no entity, but the initial expression + -- does, then they have most likely been swapped. + + if Nkind (Init_Value_Expr) = N_Attribute_Reference + or else Is_Entity_Name (Init_Value_Expr) + then + Error_Msg_N ("\\possible swap of reducer and initial " & + "value!", + Reducer_N); + end if; + return; + + else + Value_Typ := Get_Value_Subtype; + Reducer_E := Entity (Reducer_N); + + -- Stop in case of no suitable interpretation or ambiguous + -- expression, an error has already been posted. - elsif Is_Entity_Name (Reducer_Subp_Name) - and then Proper_Op (Entity (Reducer_Subp_Name)) + if No (Value_Typ) then + return; + + elsif not Is_Reducer_Subprogram (Reducer_E) then + Error_Msg_N ("no suitable reducer subprogram found", + Reducer_N); + return; + end if; + end if; + + -- After resolving the reducer, determine the correct + -- Accum_Subtype: if the reducer is an attribute (Min or Max), + -- then the prefix type is the accumulation type. + + if Nkind (Reducer_E) = N_Attribute_Reference then + Accum_Typ := Etype (Prefix (Reducer_E)); + + -- If an operator from standard, then the type of its first + -- formal woudl be Any_Type, in this case we make sure we don't + -- use an universal type to avoid resolution problems later on. + + elsif Ekind (Reducer_E) = E_Operator + or else Scope (Reducer_E) = Standard_Standard then - Op := Entity (Reducer_Subp_Name); - Set_Etype (N, Typ); + if Accum_Typ = Universal_Integer then + Accum_Typ := Standard_Integer; + elsif Accum_Typ = Universal_Real then + Accum_Typ := Standard_Float; + end if; + + -- Otherwise, the Accum_Subtype is the subtype of the first + -- formal of the reducer subprogram RM 4.5.10(19/5). + + else + Accum_Typ := Etype (First_Formal (Reducer_E)); end if; + Set_Etype (N, Accum_Typ); - if No (Op) then - Error_Msg_N ("no suitable reducer subprogram found", - Reducer_Subp_Name); + -- Accumulation type must be nonlimited, RM 4.5.10(8/5) + + if Is_Limited_Type (Accum_Typ) then + Error_Msg_N + ("accumulated subtype of Reduce must be nonlimited", N); + end if; + + -- Complete the resolution of the reduction expression by + -- resolving the initial expression and array aggregate. + + Resolve (Init_Value_Expr, Accum_Typ); + if Nkind (P) = N_Aggregate then + Resolve_Aggregate (P, + Make_Array_Type (Index => Standard_Positive, + Value => Value_Typ)); else - Resolve (Init_Value_Exp, Typ); + Resolve (P); end if; end; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index a44016c..6d6765b 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -7753,6 +7753,11 @@ package body Sem_Res is Decl : Node_Id; Local : Entity_Id := Empty; + Save_Hidden_Map : constant Elist_Id := New_Elmt_List; + -- Stores the map of identifiers, and corresponding entities, that + -- temporarily loose visibility due to homonym declarations in the + -- current declare expression. + function Replace_Local (N : Node_Id) return Traverse_Result; -- Use a tree traversal to replace each occurrence of the name of -- a local object declared in the construct, with the corresponding @@ -7817,6 +7822,19 @@ package body Sem_Res is Next (D); end loop; end; + + -- Homonyms of the new local declaration are saved to be restored + -- after the resolution of the declare block's expression. + + Append_Elmt (Local, Save_Hidden_Map); + Append_Elmt (Get_Name_Entity_Id (Chars (Local)), Save_Hidden_Map); + + -- Update the references to local in the name table and make them + -- immediately visible to be available within the expression. + + Set_Current_Entity (Local); + Set_Is_Immediately_Visible (Local); + Set_Is_Not_Self_Hidden (Local); end if; Next (Decl); @@ -7832,6 +7850,20 @@ package body Sem_Res is Resolve (Expr, Typ); Check_Unset_Reference (Expr); + + -- Restore any hidden entity homonyms to a local one + + declare + Cursor : Elmt_Id := First_Elmt (Save_Hidden_Map); + Name : Name_Id; + begin + while Present (Cursor) loop + Name := Chars (Node (Cursor)); + Next_Elmt (Cursor); + Set_Name_Entity_Id (Name, Node (Cursor)); + Next_Elmt (Cursor); + end loop; + end; end Resolve_Declare_Expression; ----------------------------------- diff --git a/gcc/testsuite/gnat.dg/reduce1.adb b/gcc/testsuite/gnat.dg/reduce1.adb index 601be4b..a1cea00 100644 --- a/gcc/testsuite/gnat.dg/reduce1.adb +++ b/gcc/testsuite/gnat.dg/reduce1.adb @@ -7,8 +7,7 @@ procedure Reduce1 is A: Arr := (2, 87); - B: Positive := A'Reduce (1, Positive'Max); -- { dg-error "no suitable" } - + B: Positive := A'Reduce (1, Positive'Max); -- { dg-error "reducer must be a subprogram, an operator, or an attribute|possible swap of reducer and initial value" } begin null; end; |