@@ -465,7 +465,7 @@ package Erroutc is
-- Tests if message buffer ends with given string preceded by a space
procedure Buffer_Remove (C : Character);
- -- Remove given character fron end of buffer if it is present
+ -- Remove given character from end of buffer if it is present
procedure Buffer_Remove (S : String);
-- Removes given string from end of buffer if it is present at end of
@@ -2280,8 +2280,10 @@ package body Exp_Aggr is
New_Code : constant List_Id := New_List;
- Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
- Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
+ Aggr_Bounds : constant Range_Nodes :=
+ Get_Index_Bounds (Aggregate_Bounds (N));
+ Aggr_L : Node_Id renames Aggr_Bounds.First;
+ Aggr_H : Node_Id renames Aggr_Bounds.Last;
-- The aggregate bounds of this specific subaggregate. Note that if the
-- code generated by Build_Array_Aggr_Code is executed then these bounds
-- are OK. Otherwise a Constraint_Error would have been raised.
@@ -2577,7 +2579,7 @@ package body Exp_Aggr is
-- If Typ is derived, and constrains discriminants of the parent type,
-- these discriminants are not components of the aggregate, and must be
-- initialized. The assignments are appended to List. The same is done
- -- if Typ derives fron an already constrained subtype of a discriminated
+ -- if Typ derives from an already constrained subtype of a discriminated
-- parent type.
procedure Init_Stored_Discriminants;
@@ -5226,6 +5228,11 @@ package body Exp_Aggr is
Others_Present := False;
if Present (Component_Associations (N)) then
+ if Is_Empty_List (Component_Associations (N)) then
+ -- an expanded null array aggregate
+ return False;
+ end if;
+
declare
Assoc : Node_Id;
Choice : Node_Id;
@@ -5914,8 +5921,10 @@ package body Exp_Aggr is
----------------------------
procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is
- Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr));
- Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr));
+ Sub_Bounds : constant Range_Nodes
+ := Get_Index_Bounds (Aggregate_Bounds (Sub_Aggr));
+ Sub_Lo : Node_Id renames Sub_Bounds.First;
+ Sub_Hi : Node_Id renames Sub_Bounds.Last;
-- The bounds of this specific subaggregate
Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
@@ -6019,7 +6028,9 @@ package body Exp_Aggr is
if Present (Component_Associations (Sub_Aggr)) then
Assoc := Last (Component_Associations (Sub_Aggr));
- if Nkind (First (Choice_List (Assoc))) = N_Others_Choice then
+ if Present (Assoc)
+ and then Nkind (First (Choice_List (Assoc))) = N_Others_Choice
+ then
Others_Present (Dim) := True;
-- An others_clause may be superfluous if previous components
@@ -6107,7 +6118,10 @@ package body Exp_Aggr is
elsif Present (Expressions (Sub_Aggr))
and then Present (Component_Associations (Sub_Aggr))
then
- Need_To_Check := True;
+ Need_To_Check :=
+ not (Is_Empty_List (Expressions (Sub_Aggr))
+ and then Is_Empty_List
+ (Component_Associations (Sub_Aggr)));
elsif Present (Component_Associations (Sub_Aggr)) then
Assoc := Last (Component_Associations (Sub_Aggr));
@@ -6666,8 +6680,8 @@ package body Exp_Aggr is
-- Save the low and high bounds of the aggregate index as well as
-- the index type for later use in checks (b) and (c) below.
- Aggr_Low (J) := Low_Bound (Aggr_Index_Range);
- Aggr_High (J) := High_Bound (Aggr_Index_Range);
+ Get_Index_Bounds
+ (Aggr_Index_Range, L => Aggr_Low (J), H => Aggr_High (J));
Aggr_Index_Typ (J) := Etype (Index_Constraint);
@@ -7180,7 +7194,8 @@ package body Exp_Aggr is
MX : constant := 80;
begin
- if Nkind (First (Choice_List (CA))) = N_Others_Choice
+ if Present (CA)
+ and then Nkind (First (Choice_List (CA))) = N_Others_Choice
and then Nkind (Expression (CA)) = N_Character_Literal
and then No (Expressions (N))
then
@@ -1405,6 +1405,7 @@ package body Ch4 is
Scan; -- past ]
Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
Set_Expressions (Aggregate_Node, New_List);
+ Set_Component_Associations (Aggregate_Node, New_List);
Set_Is_Homogeneous_Aggregate (Aggregate_Node);
return Aggregate_Node;
end if;
@@ -404,11 +404,25 @@ package body Sem_Aggr is
-- The bounds of the aggregate itype are cooked up to look reasonable
-- (in this particular case the bounds will be 1 .. 2).
+ function Is_Null_Aggregate (N : Node_Id) return Boolean;
+ -- Returns True for a "[]" aggregate (an Ada 2022 feature), even after
+ -- it has been transformed by expansion. Returns False otherwise.
+
procedure Make_String_Into_Aggregate (N : Node_Id);
-- A string literal can appear in a context in which a one dimensional
-- array of characters is expected. This procedure simply rewrites the
-- string as an aggregate, prior to resolution.
+ function Resolve_Null_Array_Aggregate (N : Node_Id) return Boolean;
+ -- For the Ada 2022 construct, build a subtype with a null range for each
+ -- dimension, using the bounds from the context subtype (if the subtype
+ -- is constrained). If the subtype is unconstrained, then the bounds
+ -- are determined in much the same way as the bounds for a null string
+ -- literal with no applicable index constraint.
+ -- Emit a check that the bounds for each dimension define a null
+ -- range; no check is emitted if it is statically known that the
+ -- check would succeed.
+
---------------------------------
-- Delta aggregate processing --
---------------------------------
@@ -754,6 +768,34 @@ package body Sem_Aggr is
and then No (Next (First (Choice_List (First (Assoc)))));
end Is_Single_Aggregate;
+ -----------------------
+ -- Is_Null_Aggregate --
+ -----------------------
+
+ function Is_Null_Aggregate (N : Node_Id) return Boolean is
+ begin
+ return Ada_Version >= Ada_2022
+ and then Is_Homogeneous_Aggregate (N)
+ and then Is_Empty_List (Expressions (N))
+ and then Is_Empty_List (Component_Associations (N));
+ end Is_Null_Aggregate;
+
+ ----------------------------------------
+ -- Is_Null_Array_Aggregate_High_Bound --
+ ----------------------------------------
+
+ function Is_Null_Array_Aggregate_High_Bound (N : Node_Id) return Boolean is
+ Original_N : constant Node_Id := Original_Node (N);
+ begin
+ return Ada_Version >= Ada_2022
+ and then not Comes_From_Source (Original_N)
+ and then Nkind (Original_N) = N_Attribute_Reference
+ and then
+ Get_Attribute_Id (Attribute_Name (Original_N)) = Attribute_Pred
+ and then Nkind (Parent (N)) in N_Range | N_Op_Le
+ and then not Comes_From_Source (Parent (N));
+ end Is_Null_Array_Aggregate_High_Bound;
+
--------------------------------
-- Make_String_Into_Aggregate --
--------------------------------
@@ -983,13 +1025,14 @@ package body Sem_Aggr is
Array_Aggregate : declare
Aggr_Resolved : Boolean;
-
Aggr_Typ : constant Entity_Id := Etype (Typ);
-- This is the unconstrained array type, which is the type against
-- which the aggregate is to be resolved. Typ itself is the array
-- type of the context which may not be the same subtype as the
-- subtype for the final aggregate.
+ Is_Null_Aggr : constant Boolean := Is_Null_Aggregate (N);
+
begin
-- In the following we determine whether an OTHERS choice is
-- allowed inside the array aggregate. The test checks the context
@@ -1021,7 +1064,11 @@ package body Sem_Aggr is
Set_Etype (N, Aggr_Typ); -- May be overridden later on
- if Nkind (Parent (N)) = N_Assignment_Statement
+ if Is_Null_Aggr then
+ Set_Etype (N, Typ);
+ Aggr_Resolved := Resolve_Null_Array_Aggregate (N);
+
+ elsif Nkind (Parent (N)) = N_Assignment_Statement
or else Inside_Init_Proc
or else (Is_Constrained (Typ)
and then Nkind (Parent (N)) in
@@ -1074,6 +1121,9 @@ package body Sem_Aggr is
Aggr_Subtyp := Any_Composite;
+ elsif Is_Null_Aggr then
+ Aggr_Subtyp := Etype (N);
+
else
Aggr_Subtyp := Array_Aggr_Subtype (N, Typ);
end if;
@@ -3139,8 +3189,12 @@ package body Sem_Aggr is
end loop;
end if;
- if Present (Component_Associations (N)) then
- if Present (Expressions (N)) then
+ if Present (Component_Associations (N))
+ and then not Is_Empty_List (Component_Associations (N))
+ then
+ if Present (Expressions (N))
+ and then not Is_Empty_List (Expressions (N))
+ then
Error_Msg_N ("container aggregate cannot be "
& "both positional and named", N);
return;
@@ -3957,6 +4011,77 @@ package body Sem_Aggr is
Check_Function_Writable_Actuals (N);
end Resolve_Extension_Aggregate;
+ ----------------------------------
+ -- Resolve_Null_Array_Aggregate --
+ ----------------------------------
+
+ function Resolve_Null_Array_Aggregate (N : Node_Id) return Boolean is
+ -- Never returns False, but declared as a function to match
+ -- other Resolve_Mumble functions.
+
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+
+ Check : Node_Id;
+ Decl : Node_Id;
+ Index : Node_Id;
+ Lo, Hi : Node_Id;
+ Constr : constant List_Id := New_List;
+ Subt : constant Entity_Id := Make_Temporary (Loc, 'S');
+
+ begin
+ -- Create a constrained subtype with null dimensions
+
+ Index := First_Index (Typ);
+ while Present (Index) loop
+ Get_Index_Bounds (Index, L => Lo, H => Hi);
+
+ -- 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)));
+
+ -- Check that high bound (i.e., low bound predecessor) exists.
+ -- Fail if low bound is low bound of base subtype (in all cases,
+ -- including modular).
+
+ Check :=
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Le (Loc, New_Copy_Tree (Lo), New_Copy_Tree (Hi)),
+ Then_Statements =>
+ New_List (Make_Raise_Constraint_Error
+ (Loc, Reason => CE_Range_Check_Failed)));
+
+ Insert_Action (N, Check);
+
+ Append (Make_Range (Loc, Lo, Hi), Constr);
+
+ Index := Next_Index (Index);
+ end loop;
+
+ Decl := Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Subt,
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Base_Type (Typ), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc, Constr)));
+
+ Insert_Action (N, Decl);
+ Set_Is_Internal (Subt);
+ Analyze (Decl);
+ Set_Etype (N, Subt);
+ Set_Compile_Time_Known_Aggregate (N);
+ Set_Aggregate_Bounds (N, New_Copy_Tree (First_Index (Etype (N))));
+
+ return True;
+ end Resolve_Null_Array_Aggregate;
+
------------------------------
-- Resolve_Record_Aggregate --
------------------------------
@@ -43,4 +43,7 @@ package Sem_Aggr is
-- WARNING: There is a matching C declaration of this subprogram in fe.h
+ function Is_Null_Array_Aggregate_High_Bound (N : Node_Id) return Boolean;
+ -- Returns True for the high bound of a null array aggregate.
+
end Sem_Aggr;
@@ -52,6 +52,7 @@ with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sdefault;
with Sem; use Sem;
+with Sem_Aggr; use Sem_Aggr;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
@@ -8438,6 +8439,12 @@ package body Sem_Attr is
or else (Is_Static_Expression (E2)
and then Is_Scalar_Type (Etype (E1))))
and then Id /= Attribute_Descriptor_Size
+
+ -- If the front-end conjures up Integer'Pred (Integer'First)
+ -- as the high bound of a null array aggregate, then we don't
+ -- want to reject that as an illegal static expression.
+
+ and then not Is_Null_Array_Aggregate_High_Bound (N)
then
Static := True;
Set_Is_Static_Expression (N, True);
@@ -9923,6 +9930,25 @@ package body Sem_Attr is
Check_Expressions;
return;
+
+ -- Rewrite the FE-constructed high bound of a null array
+ -- aggregate to raise CE.
+
+ elsif Is_Signed_Integer_Type (P_Type)
+ and then Expr_Value (E1) =
+ Expr_Value (Type_Low_Bound (P_Base_Type))
+ and then Is_Null_Array_Aggregate_High_Bound (N)
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "Pred of `&''First`",
+ CE_Overflow_Check_Failed,
+ Ent => P_Base_Type,
+ Warn => True);
+
+ Rewrite (N, Make_Raise_Constraint_Error (Sloc (N),
+ Reason => CE_Overflow_Check_Failed));
+ Set_Etype (N, P_Base_Type);
+ return;
end if;
Fold_Uint (N, Expr_Value (E1) - 1, Static);
@@ -43,6 +43,7 @@ with Opt; use Opt;
with Par_SCO; use Par_SCO;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aggr; use Sem_Aggr;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
@@ -6054,6 +6055,16 @@ package body Sem_Eval is
------------------
procedure Out_Of_Range (N : Node_Id) is
+
+ -- If the FE conjures up an expression that would normally be
+ -- an illegal static expression (e.g., an integer literal with
+ -- a value outside of its base subtype), we don't want to
+ -- flag it as illegal; we only want a warning in such cases.
+
+ function Force_Warning return Boolean is
+ (if Comes_From_Source (Original_Node (N)) then False
+ elsif Nkind (Original_Node (N)) = N_Type_Conversion then True
+ else Is_Null_Array_Aggregate_High_Bound (N));
begin
-- If we have the static expression case, then this is an illegality
-- in Ada 95 mode, except that in an instance, we never generate an
@@ -6093,9 +6104,7 @@ package body Sem_Eval is
-- Determine if the out-of-range violation constitutes a warning
-- or an error based on context, according to RM 4.9 (34/3).
- if Nkind (Original_Node (N)) = N_Type_Conversion
- and then not Comes_From_Source (Original_Node (N))
- then
+ if Force_Warning then
Apply_Compile_Time_Constraint_Error
(N, "value not in range of}??", CE_Range_Check_Failed);
else