@@ -6454,15 +6454,15 @@ package body Exp_Ch4 is
Rop : constant Node_Id := Right_Opnd (N);
Static : constant Boolean := Is_OK_Static_Expression (N);
- procedure Substitute_Valid_Check;
+ procedure Substitute_Valid_Test;
-- Replaces node N by Lop'Valid. This is done when we have an explicit
-- test for the left operand being in range of its subtype.
- ----------------------------
- -- Substitute_Valid_Check --
- ----------------------------
+ ---------------------------
+ -- Substitute_Valid_Test --
+ ---------------------------
- procedure Substitute_Valid_Check is
+ procedure Substitute_Valid_Test is
function Is_OK_Object_Reference (Nod : Node_Id) return Boolean;
-- Determine whether arbitrary node Nod denotes a source object that
-- may safely act as prefix of attribute 'Valid.
@@ -6502,7 +6502,7 @@ package body Exp_Ch4 is
return False;
end Is_OK_Object_Reference;
- -- Start of processing for Substitute_Valid_Check
+ -- Start of processing for Substitute_Valid_Test
begin
Rewrite (N,
@@ -6526,7 +6526,7 @@ package body Exp_Ch4 is
Error_Msg_N -- CODEFIX
("\??use ''Valid attribute instead", N);
end if;
- end Substitute_Valid_Check;
+ end Substitute_Valid_Test;
-- Local variables
@@ -6579,7 +6579,7 @@ package body Exp_Ch4 is
-- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
-- checks have changed the type of the left operand.
- and then Nkind (Rop) in N_Has_Entity
+ and then Is_Entity_Name (Rop)
and then Ltyp = Entity (Rop)
-- Skip this for predicated types, where such expressions are a
@@ -6587,7 +6587,7 @@ package body Exp_Ch4 is
and then No (Predicate_Function (Ltyp))
then
- Substitute_Valid_Check;
+ Substitute_Valid_Test;
return;
end if;
@@ -6605,26 +6605,42 @@ package body Exp_Ch4 is
Lo : constant Node_Id := Low_Bound (Rop);
Hi : constant Node_Id := High_Bound (Rop);
- Lo_Orig : constant Node_Id := Original_Node (Lo);
- Hi_Orig : constant Node_Id := Original_Node (Hi);
-
- Lcheck : Compare_Result;
- Ucheck : Compare_Result;
+ Lo_Orig : constant Node_Id := Original_Node (Lo);
+ Hi_Orig : constant Node_Id := Original_Node (Hi);
+ Rop_Orig : constant Node_Id := Original_Node (Rop);
+
+ Comes_From_Simple_Range_In_Source : constant Boolean :=
+ Comes_From_Source (N)
+ and then not
+ (Is_Entity_Name (Rop_Orig)
+ and then Is_Type (Entity (Rop_Orig))
+ and then Present (Predicate_Function (Entity (Rop_Orig))));
+ -- This is true for a membership test present in the source with a
+ -- range or mark for a subtype that is not predicated. As already
+ -- explained a few lines above, we do not want to give warnings on
+ -- a test with a mark for a subtype that is predicated.
Warn : constant Boolean :=
Constant_Condition_Warnings
- and then Comes_From_Source (N)
+ and then Comes_From_Simple_Range_In_Source
and then not In_Instance;
-- This must be true for any of the optimization warnings, we
-- clearly want to give them only for source with the flag on. We
-- also skip these warnings in an instance since it may be the
-- case that different instantiations have different ranges.
+ Lcheck : Compare_Result;
+ Ucheck : Compare_Result;
+
begin
- -- If test is explicit x'First .. x'Last, replace by valid check
+ -- If test is explicit x'First .. x'Last, replace by 'Valid test
if Is_Scalar_Type (Ltyp)
+ -- Only relevant for source comparisons
+
+ and then Comes_From_Simple_Range_In_Source
+
-- And left operand is X'First where X matches left operand
-- type (this eliminates cases of type mismatch, including
-- the cases where ELIMINATED/MINIMIZED mode has changed the
@@ -6632,21 +6648,17 @@ package body Exp_Ch4 is
and then Nkind (Lo_Orig) = N_Attribute_Reference
and then Attribute_Name (Lo_Orig) = Name_First
- and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
+ and then Is_Entity_Name (Prefix (Lo_Orig))
and then Entity (Prefix (Lo_Orig)) = Ltyp
-- Same tests for right operand
and then Nkind (Hi_Orig) = N_Attribute_Reference
and then Attribute_Name (Hi_Orig) = Name_Last
- and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
+ and then Is_Entity_Name (Prefix (Hi_Orig))
and then Entity (Prefix (Hi_Orig)) = Ltyp
-
- -- Relevant only for source cases
-
- and then Comes_From_Source (N)
then
- Substitute_Valid_Check;
+ Substitute_Valid_Test;
goto Leave;
end if;
@@ -6655,7 +6667,7 @@ package body Exp_Ch4 is
-- for substituting a valid test. We only do this for discrete
-- types, since it won't arise in practice for float types.
- if Comes_From_Source (N)
+ if Comes_From_Simple_Range_In_Source
and then Is_Discrete_Type (Ltyp)
and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp))
@@ -6668,7 +6680,7 @@ package body Exp_Ch4 is
-- have a test in the generic that makes sense with some types
-- and not with other types.
- -- Similarly, do not rewrite membership as a validity check if
+ -- Similarly, do not rewrite membership as a 'Valid test if
-- within the predicate function for the type.
-- Finally, if the original bounds are type conversions, even
@@ -6688,7 +6700,7 @@ package body Exp_Ch4 is
null;
else
- Substitute_Valid_Check;
+ Substitute_Valid_Test;
goto Leave;
end if;
end if;
@@ -6823,12 +6835,12 @@ package body Exp_Ch4 is
goto Leave;
-- If type is scalar type, rewrite as x in t'First .. t'Last.
- -- This reason we do this is that the bounds may have the wrong
+ -- The reason we do this is that the bounds may have the wrong
-- type if they come from the original type definition. Also this
-- way we get all the processing above for an explicit range.
- -- Don't do this for predicated types, since in this case we
- -- want to check the predicate.
+ -- Don't do this for predicated types, since in this case we want
+ -- to generate the predicate check at the end of the function.
elsif Is_Scalar_Type (Typ) then
if No (Predicate_Function (Typ)) then
@@ -6843,6 +6855,7 @@ package body Exp_Ch4 is
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
Prefix => New_Occurrence_Of (Typ, Loc))));
+
Analyze_And_Resolve (N, Restyp);
end if;
@@ -7150,6 +7163,24 @@ package body Exp_Ch4 is
and then Current_Scope /= PFunc
and then Nkind (Rop) /= N_Range
then
+ -- First apply the transformation that was skipped above
+
+ if Is_Scalar_Type (Rtyp) then
+ Rewrite (Rop,
+ Make_Range (Loc,
+ Low_Bound =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_First,
+ Prefix => New_Occurrence_Of (Rtyp, Loc)),
+
+ High_Bound =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Last,
+ Prefix => New_Occurrence_Of (Rtyp, Loc))));
+
+ Analyze_And_Resolve (N, Restyp);
+ end if;
+
if not In_Range_Check then
-- Indicate via Static_Mem parameter that this predicate
-- evaluation is for a membership test.
@@ -7169,10 +7200,6 @@ package body Exp_Ch4 is
Set_Analyzed (Left_Opnd (N));
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
-
- -- All done, skip attempt at compile time determination of result
-
- return;
end if;
end Predicate_Check;
end Expand_N_In;
@@ -10105,6 +10105,51 @@ package body Sem_Res is
then
T := Etype (R);
+ -- If the left operand is of a universal numeric type and the right
+ -- operand is not, we do not resolve the operands to the tested type
+ -- but to the universal type instead. If not conforming to the letter,
+ -- it's conforming to the spirit of the specification of membership
+ -- tests, which are typically used to guard a specific operation and
+ -- ought not to fail a check in doing so. Without this, in the case of
+
+ -- type Small_Length is range 1 .. 16;
+
+ -- function Is_Small_String (S : String) return Boolean is
+ -- begin
+ -- return S'Length in Small_Length;
+ -- end;
+
+ -- the function Is_Small_String would fail a range check for strings
+ -- larger than 127 characters.
+
+ elsif not Is_Overloaded (L)
+ and then Is_Universal_Numeric_Type (Etype (L))
+ and then (Is_Overloaded (R)
+ or else not Is_Universal_Numeric_Type (Etype (R)))
+ then
+ T := Etype (L);
+
+ -- If the right operand is 'Range, we first need to resolve it (to
+ -- the tested type) so that it is rewritten as an N_Range, before
+ -- converting its bounds and resolving it again below.
+
+ if Nkind (R) = N_Attribute_Reference
+ and then Attribute_Name (R) = Name_Range
+ then
+ Resolve (R);
+ end if;
+
+ -- If the right operand is an N_Range, we convert its bounds to the
+ -- universal type before resolving it.
+
+ if Nkind (R) = N_Range then
+ Rewrite (R,
+ Make_Range (Sloc (R),
+ Low_Bound => Convert_To (T, Low_Bound (R)),
+ High_Bound => Convert_To (T, High_Bound (R))));
+ Analyze (R);
+ end if;
+
-- Ada 2005 (AI-251): Support the following case:
-- type I is interface;
@@ -10124,6 +10169,7 @@ package body Sem_Res is
and then not Is_Interface (Etype (R))
then
return;
+
else
T := Intersect_Types (L, R);
end if;
From: Eric Botcazou <ebotcazou@adacore.com> When a membership test is applied to a nonstatic expression of a universal type, for example an attribute whose type is universal_integer and whose prefix is not static, the operation is performed using the tested type that is determined by the choice list. In particular, a check that the value of the expression lies in the range of the tested type may be generated before the test is actually performed. This goes against the spirit of membership tests, which are typically used to guard a specific operation and ought not to fail a check in doing so. Therefore the resolution of the operands of membership tests is changed in this case to use the universal type instead of the tested type. The final computation of the type used to actually perform the test is left to the expander, which already has the appropriate circuitry. This nevertheless requires fixing an irregularity in the expansion of the subtype_mark form of membership tests, which was dependent on the presence of predicates for the subtype; the confusing name of a routine used by this expansion is also changed in the process. gcc/ada/ * exp_ch4.adb (Expand_N_In) <Substitute_Valid_Check>: Rename to... <Substitute_Valid_Test>: ...this. Use Is_Entity_Name to test for the presence of entity references. Do not warn or substitute a valid test for a test with a mark for a subtype that is predicated. Apply the same transformation for a test with a mark for a subtype that is predicated as for a subtype that is not. Remove useless return statement. * sem_res.adb (Resolve_Membership_Op): Perform a special resolution if the left operand is of a universal numeric type. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_ch4.adb | 93 +++++++++++++++++++++++++++++---------------- gcc/ada/sem_res.adb | 46 ++++++++++++++++++++++ 2 files changed, 106 insertions(+), 33 deletions(-)