-- 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 --
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.
-----------------------
-----------------------
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
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.
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 =>
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
-- 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))));
-- 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:
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);
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
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
+ 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
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;
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.
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;
-- 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;
then
declare
Discard : Node_Id;
- pragma Unreferenced (Discard);
begin
Discard := Compile_Time_Constraint_Error
(Reducer_N,
projects / thirdparty / gcc.git / commitdiff
