@@ -102,6 +102,11 @@ package body Sem_Aggr is
-- simple insertion sort is used since the choices in a case statement will
-- usually be in near sorted order.
+ function Cannot_Compute_High_Bound (Index : Entity_Id) return Boolean;
+ -- Determines if the type of the given array aggregate index is a modular
+ -- type or an enumeration type that will raise CE at runtime when computing
+ -- the high bound of a null aggregate.
+
procedure Check_Can_Never_Be_Null (Typ : Entity_Id; Expr : Node_Id);
-- Ada 2005 (AI-231): Check bad usage of null for a component for which
-- null exclusion (NOT NULL) is specified. Typ can be an E_Array_Type for
@@ -121,6 +126,13 @@ package body Sem_Aggr is
-- Expression is also OK in an instance or inlining context, because we
-- have already preanalyzed and it is known to be type correct.
+ procedure Report_Null_Array_Constraint_Error
+ (N : Node_Id;
+ Index_Typ : Entity_Id);
+ -- N is a null array aggregate indexed by the given enumeration type or
+ -- modular type. Report a warning notifying that CE will be raised at
+ -- runtime. Under SPARK mode an error is reported instead of a warning.
+
------------------------------------------------------
-- Subprograms used for RECORD AGGREGATE Processing --
------------------------------------------------------
@@ -513,27 +525,108 @@ package body Sem_Aggr is
if Dim < Aggr_Dimension then
- -- Process positional components
+ if not Is_Null_Aggregate (N) then
- if Present (Expressions (N)) then
- Expr := First (Expressions (N));
- while Present (Expr) loop
- Collect_Aggr_Bounds (Expr, Dim + 1);
- Next (Expr);
- end loop;
- end if;
+ -- Process positional components
+
+ if Present (Expressions (N)) then
+ Expr := First (Expressions (N));
+ while Present (Expr) loop
+ Collect_Aggr_Bounds (Expr, Dim + 1);
+ Next (Expr);
+ end loop;
+ end if;
- -- Process component associations
+ -- Process component associations
- if Present (Component_Associations (N)) then
- Is_Fully_Positional := False;
+ if Present (Component_Associations (N)) then
+ Is_Fully_Positional := False;
- Assoc := First (Component_Associations (N));
- while Present (Assoc) loop
- Expr := Expression (Assoc);
- Collect_Aggr_Bounds (Expr, Dim + 1);
- Next (Assoc);
- end loop;
+ Assoc := First (Component_Associations (N));
+ while Present (Assoc) loop
+ Expr := Expression (Assoc);
+ Collect_Aggr_Bounds (Expr, Dim + 1);
+
+ -- Propagate the error; it is not done in other cases to
+ -- avoid replacing this aggregate by a CE node (required
+ -- to report complementary warnings when the expression
+ -- is resolved).
+
+ if Is_Null_Aggregate (Expr)
+ and then Raises_Constraint_Error (Expr)
+ then
+ Set_Raises_Constraint_Error (N);
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end if;
+
+ -- For null aggregates, build the bounds of their inner dimensions
+ -- (if not previously done). They are required for building the
+ -- aggregate itype.
+
+ elsif No (Aggr_Range (Dim + 1)) then
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Index : Node_Id;
+ Index_Typ : Entity_Id;
+ Lo, Hi : Node_Id;
+ Null_Range : Node_Id;
+ Num_Dim : Pos := 1;
+
+ begin
+ -- Move the index to the first dimension implicitly included
+ -- in this null aggregate.
+
+ Index := First_Index (Typ);
+ while Num_Dim <= Dim loop
+ Next_Index (Index);
+ Num_Dim := Num_Dim + 1;
+ end loop;
+
+ while Present (Index) loop
+ Get_Index_Bounds (Index, L => Lo, H => Hi);
+ Index_Typ := Etype (Index);
+
+ if Cannot_Compute_High_Bound (Index) then
+ -- To avoid reporting spurious errors we use the upper
+ -- bound as the higger bound of this index; this value
+ -- will not be used to generate code because this
+ -- aggregate will be replaced by a raise CE node.
+
+ Hi := New_Copy_Tree (Lo);
+
+ if not Raises_Constraint_Error (N) then
+ Report_Null_Array_Constraint_Error (N, Index_Typ);
+ Set_Raises_Constraint_Error (N);
+ end if;
+
+ else
+ -- The upper bound is the predecessor of the lower
+ -- bound.
+
+ Hi := Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Index_Typ, Loc),
+ Attribute_Name => Name_Pred,
+ Expressions => New_List (New_Copy_Tree (Lo)));
+ end if;
+
+ Null_Range := Make_Range (Loc, New_Copy_Tree (Lo), Hi);
+ Analyze_And_Resolve (Null_Range, Index_Typ);
+
+ pragma Assert (No (Aggr_Range (Num_Dim)));
+ Aggr_Low (Num_Dim) := Low_Bound (Null_Range);
+ Aggr_High (Num_Dim) := High_Bound (Null_Range);
+ Aggr_Range (Num_Dim) := Null_Range;
+
+ Num_Dim := Num_Dim + 1;
+ Next_Index (Index);
+ end loop;
+
+ pragma Assert (Num_Dim = Aggr_Dimension + 1);
+ end;
end if;
end if;
end Collect_Aggr_Bounds;
@@ -552,7 +645,7 @@ package body Sem_Aggr is
-- Make sure that the list of index constraints is properly attached to
-- the tree, and then collect the aggregate bounds.
- -- If no aggregaate bounds have been set, this is an aggregate with
+ -- If no aggregate bounds have been set, this is an aggregate with
-- iterator specifications and a dynamic size to be determined by
-- first pass of expanded code.
@@ -685,6 +778,41 @@ package body Sem_Aggr is
return Itype;
end Array_Aggr_Subtype;
+ -------------------------------
+ -- Cannot_Compute_High_Bound --
+ -------------------------------
+
+ function Cannot_Compute_High_Bound (Index : Entity_Id) return Boolean is
+ Index_Type : constant Entity_Id := Etype (Index);
+ Lo, Hi : Node_Id;
+
+ begin
+ if not Is_Modular_Integer_Type (Index_Type)
+ and then not Is_Enumeration_Type (Index_Type)
+ then
+ return False;
+
+ elsif Index_Type = Base_Type (Index_Type) then
+ return True;
+
+ else
+ Get_Index_Bounds (Index, L => Lo, H => Hi);
+
+ if Compile_Time_Known_Value (Lo) then
+ if Is_Enumeration_Type (Index_Type)
+ and then not Is_Character_Type (Index_Type)
+ then
+ return Enumeration_Pos (Entity (Lo))
+ = Enumeration_Pos (First_Literal (Base_Type (Index_Type)));
+ else
+ return Expr_Value (Lo) = Uint_0;
+ end if;
+ end if;
+ end if;
+
+ return False;
+ end Cannot_Compute_High_Bound;
+
--------------------------------
-- Check_Misspelled_Component --
--------------------------------
@@ -979,6 +1107,27 @@ package body Sem_Aggr is
Rewrite (N, New_N);
end Make_String_Into_Aggregate;
+ ----------------------------------------
+ -- Report_Null_Array_Constraint_Error --
+ ----------------------------------------
+
+ procedure Report_Null_Array_Constraint_Error
+ (N : Node_Id;
+ Index_Typ : Entity_Id) is
+ begin
+ Error_Msg_Warn := SPARK_Mode /= On;
+
+ if Is_Modular_Integer_Type (Index_Typ) then
+ Error_Msg_N
+ ("null array aggregate indexed by a modular type<<", N);
+ else
+ Error_Msg_N
+ ("null array aggregate indexed by an enumeration type<<", N);
+ end if;
+
+ Error_Msg_N ("\Constraint_Error [<<", N);
+ end Report_Null_Array_Constraint_Error;
+
-----------------------
-- Resolve_Aggregate --
-----------------------
@@ -1459,6 +1608,11 @@ package body Sem_Aggr is
-- cannot statically evaluate From. Otherwise it stores this static
-- value into Value.
+ function Has_Null_Aggregate_Raising_Constraint_Error
+ (Expr : Node_Id) return Boolean;
+ -- Determines if the given expression has some null aggregate that will
+ -- cause raising CE at runtime.
+
function Resolve_Aggr_Expr
(Expr : Node_Id;
Single_Elmt : Boolean) return Boolean;
@@ -1478,6 +1632,11 @@ package body Sem_Aggr is
Index_Typ : Entity_Id);
-- For AI12-061
+ function Subtract (Val : Uint; To : Node_Id) return Node_Id;
+ -- Creates a new expression node where Val is subtracted to expression
+ -- To. Tries to constant fold whenever possible. To must be an already
+ -- analyzed expression.
+
procedure Warn_On_Null_Component_Association (Expr : Node_Id);
-- Expr is either a conditional expression or a case expression of an
-- iterated component association initializing the aggregate N with
@@ -1747,6 +1906,41 @@ package body Sem_Aggr is
end if;
end Get;
+ -------------------------------------------------
+ -- Has_Null_Aggregate_Raising_Constraint_Error --
+ -------------------------------------------------
+
+ function Has_Null_Aggregate_Raising_Constraint_Error
+ (Expr : Node_Id) return Boolean
+ is
+ function Process (N : Node_Id) return Traverse_Result;
+ -- Process one node in search for generic formal type
+
+ -------------
+ -- Process --
+ -------------
+
+ function Process (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Aggregate
+ and then Is_Null_Aggregate (N)
+ and then Raises_Constraint_Error (N)
+ then
+ return Abandon;
+ end if;
+
+ return OK;
+ end Process;
+
+ function Traverse is new Traverse_Func (Process);
+ -- Traverse tree to look for null aggregates that will raise CE
+
+ -- Start of processing for Has_Null_Aggregate_Raising_Constraint_Error
+
+ begin
+ return Traverse (Expr) = Abandon;
+ end Has_Null_Aggregate_Raising_Constraint_Error;
+
-----------------------
-- Resolve_Aggr_Expr --
-----------------------
@@ -1871,7 +2065,8 @@ package body Sem_Aggr is
end if;
if Raises_Constraint_Error (Expr)
- and then Nkind (Parent (Expr)) /= N_Component_Association
+ and then (Nkind (Parent (Expr)) /= N_Component_Association
+ or else Is_Null_Aggregate (Expr))
then
Set_Raises_Constraint_Error (N);
end if;
@@ -2017,6 +2212,108 @@ package body Sem_Aggr is
End_Scope;
end Resolve_Iterated_Component_Association;
+ --------------
+ -- Subtract --
+ --------------
+
+ function Subtract (Val : Uint; To : Node_Id) return Node_Id is
+ Expr_Pos : Node_Id;
+ Expr : Node_Id;
+ To_Pos : Node_Id;
+
+ begin
+ if Raises_Constraint_Error (To) then
+ return To;
+ end if;
+
+ -- First test if we can do constant folding
+
+ if Compile_Time_Known_Value (To)
+ or else Nkind (To) = N_Integer_Literal
+ then
+ Expr_Pos := Make_Integer_Literal (Loc, Expr_Value (To) - Val);
+ Set_Is_Static_Expression (Expr_Pos);
+ Set_Etype (Expr_Pos, Etype (To));
+ Set_Analyzed (Expr_Pos, Analyzed (To));
+
+ if not Is_Enumeration_Type (Index_Typ) then
+ Expr := Expr_Pos;
+
+ -- If we are dealing with enumeration return
+ -- Index_Typ'Val (Expr_Pos)
+
+ else
+ Expr :=
+ Make_Attribute_Reference
+ (Loc,
+ Prefix => New_Occurrence_Of (Index_Typ, Loc),
+ Attribute_Name => Name_Val,
+ Expressions => New_List (Expr_Pos));
+ end if;
+
+ return Expr;
+ end if;
+
+ -- If we are here no constant folding possible
+
+ if not Is_Enumeration_Type (Index_Base) then
+ Expr :=
+ Make_Op_Subtract (Loc,
+ Left_Opnd => Duplicate_Subexpr (To),
+ Right_Opnd => Make_Integer_Literal (Loc, Val));
+
+ -- If we are dealing with enumeration return
+ -- Index_Typ'Val (Index_Typ'Pos (To) - Val)
+
+ else
+ To_Pos :=
+ Make_Attribute_Reference
+ (Loc,
+ Prefix => New_Occurrence_Of (Index_Typ, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions => New_List (Duplicate_Subexpr (To)));
+
+ Expr_Pos :=
+ Make_Op_Subtract (Loc,
+ Left_Opnd => To_Pos,
+ Right_Opnd => Make_Integer_Literal (Loc, Val));
+
+ Expr :=
+ Make_Attribute_Reference
+ (Loc,
+ Prefix => New_Occurrence_Of (Index_Typ, Loc),
+ Attribute_Name => Name_Val,
+ Expressions => New_List (Expr_Pos));
+
+ -- If the index type has a non standard representation, the
+ -- attributes 'Val and 'Pos expand into function calls and the
+ -- resulting expression is considered non-safe for reevaluation
+ -- by the backend. Relocate it into a constant temporary in order
+ -- to make it safe for reevaluation.
+
+ if Has_Non_Standard_Rep (Etype (N)) then
+ declare
+ Def_Id : Entity_Id;
+
+ begin
+ Def_Id := Make_Temporary (Loc, 'R', Expr);
+ Set_Etype (Def_Id, Index_Typ);
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Index_Typ, Loc),
+ Constant_Present => True,
+ Expression => Relocate_Node (Expr)));
+
+ Expr := New_Occurrence_Of (Def_Id, Loc);
+ end;
+ end if;
+ end if;
+
+ return Expr;
+ end Subtract;
+
----------------------------------------
-- Warn_On_Null_Component_Association --
----------------------------------------
@@ -2726,6 +3023,19 @@ package body Sem_Aggr is
Related_Nod => N);
end if;
+ -- Propagate the attribute Raises_CE when it was reported on a
+ -- null aggregate. This will cause replacing the aggregate by a
+ -- raise CE node; it is not done in other cases to avoid such
+ -- replacement and report complementary warnings when the
+ -- expression is resolved.
+
+ if Present (Expression (Assoc))
+ and then Has_Null_Aggregate_Raising_Constraint_Error
+ (Expression (Assoc))
+ then
+ Set_Raises_Constraint_Error (N);
+ end if;
+
Next (Assoc);
end loop;
@@ -3208,8 +3518,32 @@ package body Sem_Aggr is
Aggr_Low := Index_Typ_Low;
end if;
- Aggr_High := Add (Nb_Elements - 1, To => Aggr_Low);
- Check_Bound (Index_Base_High, Aggr_High);
+ -- Report a warning when the index type of a null array aggregate
+ -- is a modular type or an enumeration type, and we know that
+ -- we will not be able to compute its high bound at runtime
+ -- (AI22-0100-2).
+
+ if Nb_Elements = Uint_0
+ and then Cannot_Compute_High_Bound (Index_Constr)
+ then
+ -- Use the low bound value for the high-bound value to avoid
+ -- reporting spurious errors; this value will not be used at
+ -- runtime because this aggregate will be replaced by a raise
+ -- CE node.
+
+ Aggr_High := Aggr_Low;
+
+ Report_Null_Array_Constraint_Error (N, Index_Typ);
+ Set_Raises_Constraint_Error (N);
+
+ elsif Nb_Elements = Uint_0 then
+ Aggr_High := Subtract (Uint_1, To => Aggr_Low);
+ Check_Bound (Index_Base_High, Aggr_High);
+
+ else
+ Aggr_High := Add (Nb_Elements - 1, To => Aggr_Low);
+ Check_Bound (Index_Base_High, Aggr_High);
+ end if;
end if;
end if;
@@ -4726,9 +5060,11 @@ package body Sem_Aggr is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
- Index : Node_Id;
- Lo, Hi : Node_Id;
- Constr : constant List_Id := New_List;
+ Constr : constant List_Id := New_List;
+ Index : Node_Id;
+ Index_Typ : Node_Id;
+ Known_Bounds : Boolean := True;
+ Lo, Hi : Node_Id;
begin
-- Attach the list of constraints at the location of the aggregate, so
@@ -4742,14 +5078,31 @@ package body Sem_Aggr is
Index := First_Index (Typ);
while Present (Index) loop
Get_Index_Bounds (Index, L => Lo, H => Hi);
+ Index_Typ := Etype (Index);
+
+ Known_Bounds := Known_Bounds
+ and Compile_Time_Known_Value (Lo)
+ and Compile_Time_Known_Value (Hi);
- -- The upper bound is the predecessor of the lower bound
+ if Cannot_Compute_High_Bound (Index) then
+ -- The upper bound is the higger bound to avoid reporting
+ -- spurious errors; this value will not be used at runtime
+ -- because this aggregate will be replaced by a raise CE node,
+ -- or the index type is formal of a generic unit.
- Hi := Make_Attribute_Reference
- (Loc,
- Prefix => New_Occurrence_Of (Etype (Index), Loc),
- Attribute_Name => Name_Pred,
- Expressions => New_List (New_Copy_Tree (Lo)));
+ Hi := New_Copy_Tree (Lo);
+
+ Report_Null_Array_Constraint_Error (N, Index_Typ);
+ Set_Raises_Constraint_Error (N);
+
+ else
+ -- The upper bound is the predecessor of the lower bound
+
+ Hi := Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Etype (Index), Loc),
+ Attribute_Name => Name_Pred,
+ Expressions => New_List (New_Copy_Tree (Lo)));
+ end if;
Append (Make_Range (Loc, New_Copy_Tree (Lo), Hi), Constr);
Analyze_And_Resolve (Last (Constr), Etype (Index));
@@ -4757,7 +5110,7 @@ package body Sem_Aggr is
Next_Index (Index);
end loop;
- Set_Compile_Time_Known_Aggregate (N);
+ Set_Compile_Time_Known_Aggregate (N, Known_Bounds);
Set_Aggregate_Bounds (N, First (Constr));
return True;
From: Javier Miranda <miranda@adacore.com> When an array has several dimensions, and inner dimmensions are initialized using Ada 2022 null array aggregates, the compiler crashes or reports spurious errors computing the bounds of the null array aggregates. This patch fixes the problem and adds new warnings reported when the index of null array aggregates is an enumeration type or a modular type and it is known at compile time that the program will raise Constraint_Error computing the bounds of the aggregate. gcc/ada/ * sem_aggr.adb (Cannot_Compute_High_Bound): New subprogram. (Report_Null_Array_Constraint_Error): New subprogram. (Collect_Aggr_Bounds): For null aggregates, build the bounds of the inner dimensions. (Has_Null_Aggregate_Raising_Constraint_Error): New subprogram. (Subtract): New subprogram. (Resolve_Array_Aggregate): Report a warning when the index of null array aggregates is an enumeration type or a modular type at we can statically determine that the program will raise CE at runtime computing its high bound. (Resolve_Null_Array_Aggregate): ditto. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/sem_aggr.adb | 415 +++++++++++++++++++++++++++++++++++++++---- 1 file changed, 384 insertions(+), 31 deletions(-)