@@ -6806,6 +6806,21 @@ package body Exp_Ch3 is
-------------------------
function Rewrite_As_Renaming return Boolean is
+
+ function OK_To_Rename_Entity_Name (N : Node_Id) return Boolean;
+ -- Return True if N denotes an entity with OK_To_Rename set
+
+ ------------------------------
+ -- OK_To_Rename_Entity_Name --
+ ------------------------------
+
+ function OK_To_Rename_Entity_Name (N : Node_Id) return Boolean is
+ begin
+ return Is_Entity_Name (N)
+ and then Ekind (Entity (N)) = E_Variable
+ and then OK_To_Rename (Entity (N));
+ end OK_To_Rename_Entity_Name;
+
Result : constant Boolean :=
-- If the object declaration appears in the form
@@ -6844,10 +6859,11 @@ package body Exp_Ch3 is
or else
(not Aliased_Present (N)
- and then Is_Entity_Name (Expr_Q)
- and then Ekind (Entity (Expr_Q)) = E_Variable
- and then OK_To_Rename (Entity (Expr_Q))
- and then Is_Entity_Name (Obj_Def));
+ and then (OK_To_Rename_Entity_Name (Expr_Q)
+ or else
+ (Nkind (Expr_Q) = N_Slice
+ and then
+ OK_To_Rename_Entity_Name (Prefix (Expr_Q)))));
begin
-- ??? Return False if there are any aspect specifications, because
-- otherwise we duplicate that corresponding implicit attribute
@@ -174,6 +174,10 @@ package body Exp_Ch4 is
-- routine is to find the real type by looking up the tree. We also
-- determine if the operation must be rounded.
+ procedure Get_First_Index_Bounds (T : Entity_Id; Lo, Hi : out Uint);
+ -- T is an array whose index bounds are all known at compile time. Return
+ -- the value of the low and high bounds of the first index of T.
+
function Get_Size_For_Range (Lo, Hi : Uint) return Uint;
-- Return the size of a small signed integer type covering Lo .. Hi, the
-- main goal being to return a size lower than that of standard types.
@@ -1328,29 +1332,17 @@ package body Exp_Ch4 is
if Ekind (Otyp) = E_String_Literal_Subtype then
return String_Literal_Length (Otyp) < 4;
- else
+ elsif Compile_Time_Known_Bounds (Otyp) then
declare
- Ityp : constant Entity_Id := Etype (First_Index (Otyp));
- Lo : constant Node_Id := Type_Low_Bound (Ityp);
- Hi : constant Node_Id := Type_High_Bound (Ityp);
- Lov : Uint;
- Hiv : Uint;
+ Lo, Hi : Uint;
begin
- if Compile_Time_Known_Value (Lo) then
- Lov := Expr_Value (Lo);
- else
- return False;
- end if;
-
- if Compile_Time_Known_Value (Hi) then
- Hiv := Expr_Value (Hi);
- else
- return False;
- end if;
-
- return Hiv < Lov + 3;
+ Get_First_Index_Bounds (Otyp, Lo, Hi);
+ return Hi < Lo + 3;
end;
+
+ else
+ return False;
end if;
end Length_Less_Than_4;
@@ -2701,6 +2693,9 @@ package body Exp_Ch4 is
-- this loop is complete, always contains the last operand (which is not
-- the same as Operands (NN), since null operands are skipped).
+ Too_Large_Max_Length : constant Unat := UI_From_Int (256);
+ -- Threshold from which the computation of maximum lengths is useless
+
-- Arrays describing the operands, only the first NN entries of each
-- array are set (NN < N when we exclude known null operands).
@@ -2711,10 +2706,15 @@ package body Exp_Ch4 is
-- Set to the corresponding entry in the Opnds list (but note that null
-- operands are excluded, so not all entries in the list are stored).
- Fixed_Length : array (1 .. N) of Uint;
+ Fixed_Length : array (1 .. N) of Unat;
-- Set to length of operand. Entries in this array are set only if the
-- corresponding entry in Is_Fixed_Length is True.
+ Max_Length : array (1 .. N) of Unat;
+ -- Set to the maximum length of operand, or Too_Large_Max_Length if it
+ -- is not known. Entries in this array are set only if the corresponding
+ -- entry in Is_Fixed_Length is False;
+
Opnd_Low_Bound : array (1 .. N) of Node_Id;
-- Set to lower bound of operand. Either an integer literal in the case
-- where the bound is known at compile time, else actual lower bound.
@@ -2727,17 +2727,24 @@ package body Exp_Ch4 is
-- is False. The entity is of type Artyp.
Aggr_Length : array (0 .. N) of Node_Id;
- -- The J'th entry in an expression node that represents the total length
+ -- The J'th entry is an expression node that represents the total length
-- of operands 1 through J. It is either an integer literal node, or a
-- reference to a constant entity with the right value, so it is fine
-- to just do a Copy_Node to get an appropriate copy. The extra zeroth
-- entry always is set to zero. The length is of type Artyp.
+ Max_Aggr_Length : Unat := Too_Large_Max_Length;
+ -- Set to the maximum total length, or at least Too_Large_Max_Length if
+ -- it is not known.
+
Low_Bound : Node_Id := Empty;
-- A tree node representing the low bound of the result (of type Ityp).
-- This is either an integer literal node, or an identifier reference to
-- a constant entity initialized to the appropriate value.
+ High_Bound : Node_Id := Empty;
+ -- A tree node representing the high bound of the result (of type Ityp)
+
Last_Opnd_Low_Bound : Node_Id := Empty;
-- A tree node representing the low bound of the last operand. This
-- need only be set if the result could be null. It is used for the
@@ -2750,9 +2757,6 @@ package body Exp_Ch4 is
-- special case of setting the right high bound for a null result.
-- This is of type Ityp.
- High_Bound : Node_Id := Empty;
- -- A tree node representing the high bound of the result (of type Ityp)
-
Result : Node_Id := Empty;
-- Result of the concatenation (of type Ityp)
@@ -2767,7 +2771,7 @@ package body Exp_Ch4 is
-- Return True if the concatenation is within the expression of the
-- declaration of a library-level object.
- function Make_Artyp_Literal (Val : Nat) return Node_Id;
+ function Make_Artyp_Literal (Val : Uint) return Node_Id;
-- This function makes an N_Integer_Literal node that is returned in
-- analyzed form with the type set to Artyp. Importantly this literal
-- is not flagged as static, so that if we do computations with it that
@@ -2810,7 +2814,7 @@ package body Exp_Ch4 is
-- Make_Artyp_Literal --
------------------------
- function Make_Artyp_Literal (Val : Nat) return Node_Id is
+ function Make_Artyp_Literal (Val : Uint) return Node_Id is
Result : constant Node_Id := Make_Integer_Literal (Loc, Val);
begin
Set_Etype (Result, Artyp);
@@ -2867,9 +2871,10 @@ package body Exp_Ch4 is
-- Local Declarations
Opnd_Typ : Entity_Id;
+ Slice_Rng : Entity_Id;
Subtyp_Ind : Entity_Id;
Ent : Entity_Id;
- Len : Uint;
+ Len : Unat;
J : Nat;
Clen : Node_Id;
Set : Boolean;
@@ -2925,7 +2930,7 @@ package body Exp_Ch4 is
-- Supply dummy entry at start of length array
- Aggr_Length (0) := Make_Artyp_Literal (0);
+ Aggr_Length (0) := Make_Artyp_Literal (Uint_0);
-- Go through operands setting up the above arrays
@@ -2969,7 +2974,7 @@ package body Exp_Ch4 is
elsif Nkind (Opnd) = N_String_Literal then
Len := String_Literal_Length (Opnd_Typ);
- if Len /= 0 then
+ if Len > 0 then
Result_May_Be_Null := False;
end if;
@@ -3010,61 +3015,47 @@ package body Exp_Ch4 is
else
-- Check constrained case with known bounds
- if Is_Constrained (Opnd_Typ) then
+ if Is_Constrained (Opnd_Typ)
+ and then Compile_Time_Known_Bounds (Opnd_Typ)
+ then
declare
- Index : constant Node_Id := First_Index (Opnd_Typ);
- Indx_Typ : constant Entity_Id := Etype (Index);
- Lo : constant Node_Id := Type_Low_Bound (Indx_Typ);
- Hi : constant Node_Id := Type_High_Bound (Indx_Typ);
+ Lo, Hi : Uint;
begin
-- Fixed length constrained array type with known at compile
-- time bounds is last case of fixed length operand.
- if Compile_Time_Known_Value (Lo)
- and then
- Compile_Time_Known_Value (Hi)
- then
- declare
- Loval : constant Uint := Expr_Value (Lo);
- Hival : constant Uint := Expr_Value (Hi);
- Len : constant Uint :=
- UI_Max (Hival - Loval + 1, Uint_0);
+ Get_First_Index_Bounds (Opnd_Typ, Lo, Hi);
+ Len := UI_Max (Hi - Lo + 1, Uint_0);
- begin
- if Len > 0 then
- Result_May_Be_Null := False;
- end if;
+ if Len > 0 then
+ Result_May_Be_Null := False;
+ end if;
- -- Capture last operand bounds if result could be null
+ -- Capture last operand bounds if result could be null
- if J = N and then Result_May_Be_Null then
- Last_Opnd_Low_Bound :=
- Convert_To (Ityp,
- Make_Integer_Literal (Loc, Expr_Value (Lo)));
+ if J = N and then Result_May_Be_Null then
+ Last_Opnd_Low_Bound :=
+ To_Ityp (Make_Integer_Literal (Loc, Lo));
- Last_Opnd_High_Bound :=
- Convert_To (Ityp,
- Make_Integer_Literal (Loc, Expr_Value (Hi)));
- end if;
+ Last_Opnd_High_Bound :=
+ To_Ityp (Make_Integer_Literal (Loc, Hi));
+ end if;
- -- Exclude null length case unless last operand
+ -- Exclude null length case unless last operand
- if J < N and then Len = 0 then
- goto Continue;
- end if;
+ if J < N and then Len = 0 then
+ goto Continue;
+ end if;
- NN := NN + 1;
- Operands (NN) := Opnd;
- Is_Fixed_Length (NN) := True;
- Fixed_Length (NN) := Len;
+ NN := NN + 1;
+ Operands (NN) := Opnd;
+ Is_Fixed_Length (NN) := True;
+ Fixed_Length (NN) := Len;
- Opnd_Low_Bound (NN) :=
- To_Ityp
- (Make_Integer_Literal (Loc, Expr_Value (Lo)));
- Set := True;
- end;
- end if;
+ Opnd_Low_Bound (NN) :=
+ To_Ityp (Make_Integer_Literal (Loc, Lo));
+ Set := True;
end;
end if;
@@ -3108,6 +3099,25 @@ package body Exp_Ch4 is
Var_Length (NN) := Make_Temporary (Loc, 'L');
+ -- If the operand is a slice, try to compute an upper bound for
+ -- its length.
+
+ if Nkind (Opnd) = N_Slice
+ and then Is_Constrained (Etype (Prefix (Opnd)))
+ and then Compile_Time_Known_Bounds (Etype (Prefix (Opnd)))
+ then
+ declare
+ Lo, Hi : Uint;
+
+ begin
+ Get_First_Index_Bounds (Etype (Prefix (Opnd)), Lo, Hi);
+ Max_Length (NN) := UI_Max (Hi - Lo + 1, Uint_0);
+ end;
+
+ else
+ Max_Length (NN) := Too_Large_Max_Length;
+ end if;
+
Append_To (Actions,
Make_Object_Declaration (Loc,
Defining_Identifier => Var_Length (NN),
@@ -3129,8 +3139,10 @@ package body Exp_Ch4 is
if NN = 1 then
if Is_Fixed_Length (1) then
Aggr_Length (1) := Make_Integer_Literal (Loc, Fixed_Length (1));
+ Max_Aggr_Length := Fixed_Length (1);
else
Aggr_Length (1) := New_Occurrence_Of (Var_Length (1), Loc);
+ Max_Aggr_Length := Max_Length (1);
end if;
-- If entry is fixed length and only fixed lengths so far, make
@@ -3142,6 +3154,7 @@ package body Exp_Ch4 is
Aggr_Length (NN) :=
Make_Integer_Literal (Loc,
Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1)));
+ Max_Aggr_Length := Intval (Aggr_Length (NN));
-- All other cases, construct an addition node for the length and
-- create an entity initialized to this length.
@@ -3151,8 +3164,11 @@ package body Exp_Ch4 is
if Is_Fixed_Length (NN) then
Clen := Make_Integer_Literal (Loc, Fixed_Length (NN));
+ Max_Aggr_Length := Max_Aggr_Length + Fixed_Length (NN);
+
else
Clen := New_Occurrence_Of (Var_Length (NN), Loc);
+ Max_Aggr_Length := Max_Aggr_Length + Max_Length (NN);
end if;
Append_To (Actions,
@@ -3277,29 +3293,38 @@ package body Exp_Ch4 is
pragma Assert (Present (Low_Bound));
- -- Now we can safely compute the upper bound, normally
- -- Low_Bound + Length - 1.
-
- High_Bound :=
- To_Ityp
- (Make_Op_Add (Loc,
- Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
- Right_Opnd =>
- Make_Op_Subtract (Loc,
- Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
- Right_Opnd => Make_Artyp_Literal (1))));
-
- -- Note that calculation of the high bound may cause overflow in some
- -- very weird cases, so in the general case we need an overflow check on
- -- the high bound. We can avoid this for the common case of string types
- -- and other types whose index is Positive, since we chose a wider range
- -- for the arithmetic type. If checks are suppressed we do not set the
- -- flag, and possibly superfluous warnings will be omitted.
+ -- Now we can compute the high bound as Low_Bound + Length - 1
- if Istyp /= Standard_Positive
- and then not Overflow_Checks_Suppressed (Istyp)
+ if Compile_Time_Known_Value (Low_Bound)
+ and then Nkind (Aggr_Length (NN)) = N_Integer_Literal
then
- Activate_Overflow_Check (High_Bound);
+ High_Bound :=
+ To_Ityp
+ (Make_Artyp_Literal
+ (Expr_Value (Low_Bound) + Intval (Aggr_Length (NN)) - 1));
+
+ else
+ High_Bound :=
+ To_Ityp
+ (Make_Op_Add (Loc,
+ Left_Opnd => To_Artyp (New_Copy_Tree (Low_Bound)),
+ Right_Opnd =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
+ Right_Opnd => Make_Artyp_Literal (Uint_1))));
+
+ -- Note that calculation of the high bound may cause overflow in some
+ -- very weird cases, so in the general case we need an overflow check
+ -- on the high bound. We can avoid this for the common case of string
+ -- types and other types whose index is Positive, since we chose a
+ -- wider range for the arithmetic type. If checks are suppressed, we
+ -- do not set the flag so superfluous warnings may be omitted.
+
+ if Istyp /= Standard_Positive
+ and then not Overflow_Checks_Suppressed (Istyp)
+ then
+ Activate_Overflow_Check (High_Bound);
+ end if;
end if;
-- Handle the exceptional case where the result is null, in which case
@@ -3312,7 +3337,7 @@ package body Exp_Ch4 is
Expressions => New_List (
Make_Op_Eq (Loc,
Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
- Right_Opnd => Make_Artyp_Literal (0)),
+ Right_Opnd => Make_Artyp_Literal (Uint_0)),
Last_Opnd_Low_Bound,
Low_Bound));
@@ -3321,7 +3346,7 @@ package body Exp_Ch4 is
Expressions => New_List (
Make_Op_Eq (Loc,
Left_Opnd => New_Copy_Tree (Aggr_Length (NN)),
- Right_Opnd => Make_Artyp_Literal (0)),
+ Right_Opnd => Make_Artyp_Literal (Uint_0)),
Last_Opnd_High_Bound,
High_Bound));
end if;
@@ -3330,6 +3355,35 @@ package body Exp_Ch4 is
Insert_Actions (Cnode, Actions, Suppress => All_Checks);
+ -- If the low bound is known at compile time and not the high bound, but
+ -- we have computed a sensible upper bound for the length, then adjust
+ -- the high bound for the subtype of the array. This will change it into
+ -- a static subtype and thus help the code generator.
+
+ if Compile_Time_Known_Value (Low_Bound)
+ and then not Compile_Time_Known_Value (High_Bound)
+ and then Max_Aggr_Length < Too_Large_Max_Length
+ then
+ declare
+ Known_High_Bound : constant Node_Id :=
+ To_Ityp
+ (Make_Artyp_Literal
+ (Expr_Value (Low_Bound) + Max_Aggr_Length - 1));
+
+ begin
+ if not Is_Out_Of_Range (Known_High_Bound, Ityp) then
+ Slice_Rng := Make_Range (Loc, Low_Bound, High_Bound);
+ High_Bound := Known_High_Bound;
+
+ else
+ Slice_Rng := Empty;
+ end if;
+ end;
+
+ else
+ Slice_Rng := Empty;
+ end if;
+
-- Now we construct an array object with appropriate bounds. We mark
-- the target as internal to prevent useless initialization when
-- Initialize_Scalars is enabled. Also since this is the actual result
@@ -3443,16 +3497,26 @@ package body Exp_Ch4 is
-- Catch the static out of range case now
- if Raises_Constraint_Error (High_Bound) then
+ if Raises_Constraint_Error (High_Bound)
+ or else Is_Out_Of_Range (High_Bound, Ityp)
+ then
-- Kill warning generated for the declaration of the static out of
-- range high bound, and instead generate a Constraint_Error with
-- an appropriate specific message.
- Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
+ if Nkind (High_Bound) = N_Integer_Literal then
+ Kill_Dead_Code (High_Bound);
+ Rewrite (High_Bound, New_Copy_Tree (Low_Bound));
+
+ else
+ Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
+ end if;
+
Apply_Compile_Time_Constraint_Error
(N => Cnode,
Msg => "concatenation result upper bound out of range??",
Reason => CE_Range_Check_Failed);
+
return;
end if;
@@ -3529,8 +3593,9 @@ package body Exp_Ch4 is
Name => New_Occurrence_Of (RTE (RR (NN)), Loc),
Parameter_Associations => Opnds));
- Result := New_Occurrence_Of (Ent, Loc);
- goto Done;
+ -- No assignments left to do below
+
+ NN := 0;
end;
end if;
end;
@@ -3553,7 +3618,7 @@ package body Exp_Ch4 is
Right_Opnd =>
Make_Op_Subtract (Loc,
Left_Opnd => Aggr_Length (J),
- Right_Opnd => Make_Artyp_Literal (1)));
+ Right_Opnd => Make_Artyp_Literal (Uint_1)));
begin
-- Singleton case, simple assignment
@@ -3614,10 +3679,15 @@ package body Exp_Ch4 is
end;
end loop;
- -- Finally we build the result, which is a reference to the array object
+ -- Finally we build the result, which is either a direct reference to
+ -- the array object or a slice of it.
Result := New_Occurrence_Of (Ent, Loc);
+ if Present (Slice_Rng) then
+ Result := Make_Slice (Loc, Result, Slice_Rng);
+ end if;
+
<<Done>>
pragma Assert (Present (Result));
Rewrite (Cnode, Result);
@@ -13318,6 +13388,24 @@ package body Exp_Ch4 is
end if;
end Fixup_Universal_Fixed_Operation;
+ ----------------------------
+ -- Get_First_Index_Bounds --
+ ----------------------------
+
+ procedure Get_First_Index_Bounds (T : Entity_Id; Lo, Hi : out Uint) is
+ Typ : Entity_Id;
+
+ begin
+ pragma Assert (Is_Array_Type (T));
+
+ -- This follows Sem_Eval.Compile_Time_Known_Bounds
+
+ Typ := Underlying_Type (Etype (First_Index (T)));
+
+ Lo := Expr_Value (Type_Low_Bound (Typ));
+ Hi := Expr_Value (Type_High_Bound (Typ));
+ end Get_First_Index_Bounds;
+
------------------------
-- Get_Size_For_Range --
------------------------