This implements static predicates for string and real types,
as defined in the RM. There is one exception, which is that
the RM allows X > "ABC" as being predicate static, but since
"ABC" > "ABA" is not static, that's peculiar, so we assume
that this is a mistake in the RM, and that string comparisons
should not be permitted as predicate-static.
The following test program shows various uses of static
predicates of all types with a range of legality tests
and tests for compile time evaluation of static predicates.
1. package TestSP is
2. subtype F1 is Float with -- OK
3. Static_Predicate => F1 > 0.0 and 4.7 > F1;
4.
5. subtype F1a is F1 with -- OK
6. Static_Predicate => F1a > 2.4;
7.
8. subtype F2 is Float with -- ERROR
9. Static_Predicate => (F2 + 1.0) > 0.0 and 4.7 > F2;
|
>>> expression is not predicate-static (RM 4.3.2(16-22))
10. subtype F3 is Float with -- OK
11. Dynamic_Predicate => (F3 + 1.0) > 0.0 and 4.7 > F3;
12. subtype F4 is Float with -- OK
13. Predicate => (F4 + 1.0) > 0.0 and 4.7 > F4;
14.
15. subtype S0 is String with -- ERROR
16. Static_Predicate => S0 > "ABC" and then "DEF" >= S0;
|
>>> expression is not predicate-static (RM 4.3.2(16-22))
17. subtype S1 is String with -- OK
18. Static_Predicate => S1 in "ABC" | "DEF";
19.
20. subtype S2 is String with -- ERROR
21. Static_Predicate => S2'First = 1 and then S2(1) = 'A';
|
>>> expression is not predicate-static (RM 4.3.2(16-22))
22. subtype S3 is String with -- OK
23. Dynamic_Predicate => S3'First = 1 and then S3(1) = 'A';
24. subtype S4 is String with -- OK
25. Predicate => S4'First = 1 and then S4(1) = 'A';
26. subtype S5 is String with -- OK
27. Predicate => S5 in "ABC" | "DEF";
28. subtype S6 is String with -- OK
29. Dynamic_Predicate => S6 in "ABC" | "DEF";
30.
31. subtype I1 is Integer with -- OK
32. Static_Predicate => I1 > 0 and 4 > I1;
33. subtype I1a is I1 with -- OK
34. Static_Predicate => I1a > 2;
35.
36. subtype I2 is Integer with -- ERROR
37. Static_Predicate => (I2 + 1) > 0 and 4 > I2;
|
>>> expression is not predicate-static (RM 4.3.2(16-22))
38. subtype I3 is Integer with -- OK
39. Dynamic_Predicate => (I3 + 1) > 0 and 4 > I3;
40. subtype I4 is Integer with -- OK
41. Predicate => (I4 + 1) > 0 and 4 > I4;
42.
43. subtype I5 is Integer with -- ERROR
44. Static_Predicate => Boolean'(I5 > 0);
|
>>> expression is not predicate-static (RM 4.3.2(16-22))
45.
46. XF1 : constant F1 := 10.0; -- WARN
|
>>> warning: static expression fails static predicate
check on "F1", expression is no longer considered
static
47. XF2 : constant F1 := 3.0; -- OK
48.
49. XF3 : constant := XF1; -- ERROR
|
>>> non-static expression used in number declaration
>>> "XF1" is not a static constant (RM 4.9(5))
50. XF4 : constant := XF2; -- OK
51.
52. XF1a : constant F1a := 1.3; -- WARN;
|
>>> warning: static expression fails static predicate
check on "F1a", expression is no longer considered
static
53. XF1b : constant F1a := 5.3; -- WARN;
|
>>> warning: static expression fails static predicate
check on "F1a", expression is no longer considered
static
54. XF1c : constant F1a := 3.7; -- OK
55.
56. XI1 : constant I1 := 10; -- WARN
|
>>> warning: static expression fails static predicate
check on "I1", expression is no longer considered
static
57. XI2 : constant I1 := 3; -- OK
58.
59. XI3 : constant := XI1; -- ERROR
|
>>> non-static expression used in number declaration
>>> "XI1" is not a static constant (RM 4.9(5))
60. XI4 : constant := XI2; -- OK
61.
62. XI1a : constant I1a := 2; -- WARN
|
>>> warning: static expression fails static predicate
check on "I1a", expression is no longer considered
static
63. XI1b : constant I1a := 7; -- WARN
|
>>> warning: static expression fails static predicate
check on "I1a", expression is no longer considered
static
64. XI1c : constant I1a := 3; -- OK
65.
66. XSa : constant S1 := "ABC"; -- OK
67.
68. Xsb : constant S1 := "DQR"; -- WARN
|
>>> warning: static expression fails static predicate
check on "S1", expression is no longer considered
static
69. XSc : constant S5 := "ABC"; -- OK
70.
71. Xsd : constant S5 := "DQR"; -- WARN
|
>>> warning: static expression fails static predicate
check on "S5", expression is no longer considered
static
72. Xse : constant S6 := "ABC"; -- OK
73.
74. Xsf : constant S6 := "DQR"; -- WARN
|
>>> warning: expression fails predicate check on "S6"
75. end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-29 Robert Dewar <de...@adacore.com>
* einfo.ads, einfo.adb (Static_Real_Or_String_Predicate): New function
(Set_Static_Real_Or_String_Predicate): New procedure
* sem_ch13.adb (Build_Predicate_Functions): Accomodate static
string predicates (Is_Predicate_Static): Handle static string
predicates.
* sem_eval.adb (Real_Or_String_Static_Predicate_Matches):
New procedure (Check_Expression_Against_Static_Predicate):
Deal with static string predicates, now fully implemented
(Eval_Relational_Op): Allow string equality/inequality as static
if not comes from source.
Index: einfo.adb
===================================================================
--- einfo.adb (revision 213161)
+++ einfo.adb (revision 213162)
@@ -223,6 +223,7 @@
-- PPC_Wrapper Node25
-- Related_Array_Object Node25
-- Static_Discrete_Predicate List25
+ -- Static_Real_Or_String_Predicate Node25
-- Task_Body_Procedure Node25
-- Dispatch_Table_Wrappers Elist26
@@ -2977,6 +2978,12 @@
return List25 (Id);
end Static_Discrete_Predicate;
+ function Static_Real_Or_String_Predicate (Id : E) return N is
+ begin
+ pragma Assert (Is_Real_Type (Id) or else Is_String_Type (Id));
+ return Node25 (Id);
+ end Static_Real_Or_String_Predicate;
+
function Status_Flag_Or_Transient_Decl (Id : E) return N is
begin
pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
@@ -5767,6 +5774,13 @@
Set_List25 (Id, V);
end Set_Static_Discrete_Predicate;
+ procedure Set_Static_Real_Or_String_Predicate (Id : E; V : N) is
+ begin
+ pragma Assert ((Is_Real_Type (Id) or else Is_String_Type (Id))
+ and then Has_Predicates (Id));
+ Set_Node25 (Id, V);
+ end Set_Static_Real_Or_String_Predicate;
+
procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E) is
begin
pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
@@ -9399,13 +9413,12 @@
E_Entry_Family =>
Write_Str ("PPC_Wrapper");
- when E_Enumeration_Type |
- E_Enumeration_Subtype |
- E_Modular_Integer_Type |
- E_Modular_Integer_Subtype |
- E_Signed_Integer_Subtype =>
+ when Discrete_Kind =>
Write_Str ("Static_Discrete_Predicate");
+ when Real_Kind =>
+ Write_Str ("Static_Real_Or_String_Predicate");
+
when others =>
Write_Str ("Field25??");
end case;
Index: einfo.ads
===================================================================
--- einfo.ads (revision 213161)
+++ einfo.ads (revision 213162)
@@ -3899,7 +3899,7 @@
-- Static_Discrete_Predicate (List25)
-- Defined in discrete types/subtypes with static predicates (with the
--- two flags Has_Predicates set and Has_Static_Predicate set). Set if the
+-- two flags Has_Predicates and Has_Static_Predicate set). Set if the
-- type/subtype has a static predicate. Points to a list of expression
-- and N_Range nodes that represent the predicate in canonical form. The
-- canonical form has entries sorted in ascending order, with duplicates
@@ -3908,6 +3908,26 @@
-- are fully analyzed and typed with the base type of the subtype. Note
-- that all entries are static and have values within the subtype range.
+-- Static_Real_Or_String_Predicate (Node25)
+-- Defined in real types/subtypes with static predicates (with the two
+-- flags Has_Predicates and Has_Static_Predicate set). Set if the type
+-- or subtype has a static predicate. Points to the return expression
+-- of the predicate function. This is the original expression given as
+-- the predicate except that occurrences of the type are replaced by
+-- occurrences of the formal parameter of the predicate function (note
+-- that the spec of this function including this formal parameter name)
+-- is available from the Subprograms_For_Type field (it can be accessed
+-- as Predicate_Function (typ). Also, in the case where a predicate is
+-- inherited, the expression is of the form:
+--
+-- expression AND THEN xxxPredicate (typ2 (ent))
+--
+-- where typ2 is the type from which the predicate is inherited, ent is
+-- the entity for the current predicate function, and xxxPredicate is the
+-- inherited predicate (from typ2). Finally for a predicate that inherits
+-- from another predicate but does not add a predicate of its own, the
+-- expression may consist of the above xxxPredicate call on its own.
+
-- Status_Flag_Or_Transient_Decl (Node15)
-- Defined in variables and constants. Applies to objects that require
-- special treatment by the finalization machinery, such as extended
@@ -5452,6 +5472,7 @@
-- Scalar_Range (Node20)
-- Delta_Value (Ureal18)
-- Small_Value (Ureal21)
+ -- Static_Real_Or_String_Predicate (Node25)
-- Has_Machine_Radix_Clause (Flag83)
-- Machine_Radix_10 (Flag84)
-- Aft_Value (synth)
@@ -5557,6 +5578,7 @@
-- Float_Rep (Uint10) (Float_Rep_Kind)
-- Default_Aspect_Value (Node19) (base type only)
-- Scalar_Range (Node20)
+ -- Static_Real_Or_String_Predicate (Node25)
-- Machine_Emax_Value (synth)
-- Machine_Emin_Value (synth)
-- Machine_Mantissa_Value (synth)
@@ -5777,6 +5799,7 @@
-- Delta_Value (Ureal18)
-- Default_Aspect_Value (Node19) (base type only)
-- Scalar_Range (Node20)
+ -- Static_Real_Or_String_Predicate (Node25)
-- Small_Value (Ureal21)
-- Has_Small_Clause (Flag67)
-- Aft_Value (synth)
@@ -6048,6 +6071,7 @@
-- E_String_Subtype
-- First_Index (Node17)
-- Component_Type (Node20) (base type only)
+ -- Static_Real_Or_String_Predicate (Node25)
-- Is_Constrained (Flag12)
-- Next_Index (synth)
-- Number_Dimensions (synth)
@@ -6791,6 +6815,7 @@
function Static_Elaboration_Desired (Id : E) return B;
function Static_Initialization (Id : E) return N;
function Static_Discrete_Predicate (Id : E) return S;
+ function Static_Real_Or_String_Predicate (Id : E) return N;
function Status_Flag_Or_Transient_Decl (Id : E) return E;
function Storage_Size_Variable (Id : E) return E;
function Stored_Constraint (Id : E) return L;
@@ -7425,6 +7450,7 @@
procedure Set_Static_Elaboration_Desired (Id : E; V : B);
procedure Set_Static_Initialization (Id : E; V : N);
procedure Set_Static_Discrete_Predicate (Id : E; V : S);
+ procedure Set_Static_Real_Or_String_Predicate (Id : E; V : N);
procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E);
procedure Set_Storage_Size_Variable (Id : E; V : E);
procedure Set_Stored_Constraint (Id : E; V : L);
@@ -8209,6 +8235,7 @@
pragma Inline (Static_Elaboration_Desired);
pragma Inline (Static_Initialization);
pragma Inline (Static_Discrete_Predicate);
+ pragma Inline (Static_Real_Or_String_Predicate);
pragma Inline (Status_Flag_Or_Transient_Decl);
pragma Inline (Storage_Size_Variable);
pragma Inline (Stored_Constraint);
@@ -8642,6 +8669,7 @@
pragma Inline (Set_Static_Elaboration_Desired);
pragma Inline (Set_Static_Initialization);
pragma Inline (Set_Static_Discrete_Predicate);
+ pragma Inline (Set_Static_Real_Or_String_Predicate);
pragma Inline (Set_Status_Flag_Or_Transient_Decl);
pragma Inline (Set_Storage_Size_Variable);
pragma Inline (Set_Stored_Constraint);
Index: ChangeLog
===================================================================
--- ChangeLog (revision 213161)
+++ ChangeLog (revision 213162)
@@ -1,5 +1,18 @@
2014-07-29 Robert Dewar <de...@adacore.com>
+ * einfo.ads, einfo.adb (Static_Real_Or_String_Predicate): New function
+ (Set_Static_Real_Or_String_Predicate): New procedure
+ * sem_ch13.adb (Build_Predicate_Functions): Accomodate static
+ string predicates (Is_Predicate_Static): Handle static string
+ predicates.
+ * sem_eval.adb (Real_Or_String_Static_Predicate_Matches):
+ New procedure (Check_Expression_Against_Static_Predicate):
+ Deal with static string predicates, now fully implemented
+ (Eval_Relational_Op): Allow string equality/inequality as static
+ if not comes from source.
+
+2014-07-29 Robert Dewar <de...@adacore.com>
+
* sem_aggr.adb, exp_ch5.adb, sem_ch5.adb, exp_util.adb, einfo.adb,
einfo.ads, sem_util.adb, sem_attr.adb, sem_case.adb, sem_eval.adb,
sem_eval.ads, sem_ch13.adb: General cleanup of static predicate
Index: sem_eval.adb
===================================================================
--- sem_eval.adb (revision 213161)
+++ sem_eval.adb (revision 213162)
@@ -227,6 +227,16 @@
-- this is an illegality if N is static, and should generate a warning
-- otherwise.
+ function Real_Or_String_Static_Predicate_Matches
+ (Val : Node_Id;
+ Typ : Entity_Id) return Boolean;
+ -- This is the function used to evaluate real or string static predicates.
+ -- Val is an unanalyzed N_Real_Literal or N_String_Literal node, which
+ -- represents the value to be tested against the predicate. Typ is the
+ -- type with the predicate, from which the predicate expression can be
+ -- extracted. The result returned is True if the given value satisfies
+ -- the predicate.
+
procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
-- N and Exp are nodes representing an expression, Exp is known to raise
-- CE. N is rewritten in term of Exp in the optimal way.
@@ -339,23 +349,36 @@
-- an explicitly specified Dynamic_Predicate whose expression met the
-- rules for being predicate-static).
- -- If we are not generating code, nothing more to do (why???)
+ -- Case of real static predicate
- if Operating_Mode < Generate_Code then
- return;
- end if;
+ if Is_Real_Type (Typ) then
+ if Real_Or_String_Static_Predicate_Matches
+ (Val => Make_Real_Literal (Sloc (Expr), Expr_Value_R (Expr)),
+ Typ => Typ)
+ then
+ return;
+ end if;
- -- If we have the real case, then for now, not implemented
+ -- Case of string static predicate
- if not Is_Discrete_Type (Typ) then
- Error_Msg_N ("??real predicate not applied", Expr);
- return;
- end if;
+ elsif Is_String_Type (Typ) then
+ if Real_Or_String_Static_Predicate_Matches
+ (Val => Expr_Value_S (Expr),
+ Typ => Typ)
+ then
+ return;
+ end if;
- -- If static predicate matches, nothing to do
+ -- Case of discrete static predicate
- if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then
- return;
+ else
+ pragma Assert (Is_Discrete_Type (Typ));
+
+ -- If static predicate matches, nothing to do
+
+ if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then
+ return;
+ end if;
end if;
-- Here we know that the predicate will fail
@@ -3052,6 +3075,10 @@
-- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
-- the result is never static, even if the operands are.
+ -- However, for internally generated nodes, we allow string equality and
+ -- inequality to be static. This is because we rewrite A in "ABC" as an
+ -- equality test A = "ABC", and the former is definitely static.
+
procedure Eval_Relational_Op (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
@@ -3289,9 +3316,16 @@
-- Only comparisons of scalars can give static results. In
-- particular, comparisons of strings never yield a static
- -- result, even if both operands are static strings.
+ -- result, even if both operands are static strings, except that
+ -- as noted above, we allow equality/inequality for strings.
- if not Is_Scalar_Type (Typ) then
+ if Is_String_Type (Typ)
+ and then not Comes_From_Source (N)
+ and then Nkind_In (N, N_Op_Eq, N_Op_Ne)
+ then
+ null;
+
+ elsif not Is_Scalar_Type (Typ) then
Is_Static_Expression := False;
Set_Is_Static_Expression (N, False);
end if;
@@ -3307,9 +3341,8 @@
Otype := Find_Universal_Operator_Type (N);
end if;
- -- For static real type expressions, we cannot use
- -- Compile_Time_Compare since it worries about run-time
- -- results which are not exact.
+ -- For static real type expressions, do not use Compile_Time_Compare
+ -- since it worries about run-time results which are not exact.
if Is_Static_Expression and then Is_Real_Type (Typ) then
declare
@@ -5322,6 +5355,112 @@
end if;
end Predicates_Match;
+ ---------------------------------------------
+ -- Real_Or_String_Static_Predicate_Matches --
+ ---------------------------------------------
+
+ function Real_Or_String_Static_Predicate_Matches
+ (Val : Node_Id;
+ Typ : Entity_Id) return Boolean
+ is
+ Expr : constant Node_Id := Static_Real_Or_String_Predicate (Typ);
+ -- The predicate expression from the type
+
+ Pfun : constant Entity_Id := Predicate_Function (Typ);
+ -- The entity for the predicate function
+
+ Ent_Name : constant Name_Id := Chars (First_Formal (Pfun));
+ -- The name of the formal of the predicate function. Occurrences of the
+ -- type name in Expr have been rewritten as references to this formal,
+ -- and it has a unique name, so we can identify references by this name.
+
+ Copy : Node_Id;
+ -- Copy of the predicate function tree
+
+ function Process (N : Node_Id) return Traverse_Result;
+ -- Function used to process nodes during the traversal in which we will
+ -- find occurrences of the entity name, and replace such occurrences
+ -- by a real literal with the value to be tested.
+
+ procedure Traverse is new Traverse_Proc (Process);
+ -- The actual traversal procedure
+
+ -------------
+ -- Process --
+ -------------
+
+ function Process (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Identifier and then Chars (N) = Ent_Name then
+ declare
+ Nod : constant Node_Id := New_Copy (Val);
+ begin
+ Set_Sloc (Nod, Sloc (N));
+ Rewrite (N, Nod);
+ return Skip;
+ end;
+
+ else
+ return OK;
+ end if;
+ end Process;
+
+ -- Start of processing for Real_Or_String_Static_Predicate_Matches
+
+ begin
+ -- First deal with special case of inherited predicate, where the
+ -- predicate expression looks like:
+
+ -- Expr and then xxPredicate (typ (Ent))
+
+ -- where Expr is the predicate expression for this level, and the
+ -- right operand is the call to evaluate the inherited predicate.
+
+ if Nkind (Expr) = N_And_Then
+ and then Nkind (Right_Opnd (Expr)) = N_Function_Call
+ then
+ -- OK we have the inherited case, so make a call to evaluate the
+ -- inherited predicate. If that fails, so do we!
+
+ if not
+ Real_Or_String_Static_Predicate_Matches
+ (Val => Val,
+ Typ => Etype (First_Formal (Entity (Name (Right_Opnd (Expr))))))
+ then
+ return False;
+ end if;
+
+ -- Use the left operand for the continued processing
+
+ Copy := Copy_Separate_Tree (Left_Opnd (Expr));
+
+ -- Case where call to predicate function appears on its own
+
+ elsif Nkind (Expr) = N_Function_Call then
+
+ -- Here the result is just the result of calling the inner predicate
+
+ return
+ Real_Or_String_Static_Predicate_Matches
+ (Val => Val,
+ Typ => Etype (First_Formal (Entity (Name (Expr)))));
+
+ -- If no inherited predicate, copy whole expression
+
+ else
+ Copy := Copy_Separate_Tree (Expr);
+ end if;
+
+ -- Now we replace occurrences of the entity by the value
+
+ Traverse (Copy);
+
+ -- And analyze the resulting static expression to see if it is True
+
+ Analyze_And_Resolve (Copy, Standard_Boolean);
+ return Is_True (Expr_Value (Copy));
+ end Real_Or_String_Static_Predicate_Matches;
+
-------------------------
-- Rewrite_In_Raise_CE --
-------------------------
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 213161)
+++ sem_ch13.adb (revision 213162)
@@ -8002,10 +8002,16 @@
-- yes even if we have an explicit Dynamic_Predicate present.
declare
- PS : constant Boolean := Is_Predicate_Static (Expr, Object_Name);
+ PS : Boolean;
EN : Node_Id;
begin
+ if not Is_Scalar_Type (Typ) and then not Is_String_Type (Typ) then
+ PS := False;
+ else
+ PS := Is_Predicate_Static (Expr, Object_Name);
+ end if;
+
-- Case where we have a predicate-static aspect
if PS then
@@ -8033,6 +8039,11 @@
if No (Static_Discrete_Predicate (Typ)) then
Set_Has_Static_Predicate (Typ, False);
end if;
+
+ -- For real or string subtype, save predicate expression
+
+ elsif Is_Real_Type (Typ) or else Is_String_Type (Typ) then
+ Set_Static_Real_Or_String_Predicate (Typ, Expr);
end if;
-- Case of dynamic predicate (expression is not predicate-static)
@@ -8060,14 +8071,13 @@
-- Now post appropriate message
if Has_Static_Predicate_Aspect (Typ) then
- if Is_Scalar_Type (Typ) then
+ if Is_Scalar_Type (Typ) or else Is_String_Type (Typ) then
Error_Msg_F
("expression is not predicate-static (RM 4.3.2(16-22))",
EN);
else
- Error_Msg_FE
- ("static predicate not allowed for non-scalar type&",
- EN, Typ);
+ Error_Msg_F
+ ("static predicate requires scalar or string type", EN);
end if;
end if;
end if;
@@ -10362,6 +10372,9 @@
-- Is_Predicate_Static --
-------------------------
+ -- Note: the basic legality of the expression has already been checked, so
+ -- we don't need to worry about cases or ranges on strings for example.
+
function Is_Predicate_Static
(Expr : Node_Id;
Nam : Name_Id) return Boolean
@@ -10462,12 +10475,6 @@
-- Start of processing for Is_Predicate_Static
begin
- -- Only scalar types can be predicate-static
-
- if not Is_Scalar_Type (Etype (Expr)) then
- return False;
- end if;
-
-- Predicate_Static means one of the following holds. Numbers are the
-- corresponding paragraph numbers in (RM 3.2.4(16-22)).
@@ -10502,7 +10509,20 @@
-- operand is the current instance, and the other is a static
-- expression.
+ -- Note: the RM is clearly wrong here in not excluding string types.
+ -- Without this exclusion, we would allow expressions like X > "ABC"
+ -- to be considered as predicate-static, which is clearly not intended,
+ -- since the idea is for predicate-static to be a subset of normal
+ -- static expressions (and "DEF" > "ABC" is not a static expression).
+
+ -- However, we do allow internally generated (not from source) equality
+ -- and inequality operations to be valid on strings (this helps deal
+ -- with cases where we transform A in "ABC" to A = "ABC).
+
elsif Nkind (Expr) in N_Op_Compare
+ and then ((not Is_String_Type (Etype (Left_Opnd (Expr))))
+ or else (Nkind_In (Expr, N_Op_Eq, N_Op_Ne)
+ and then not Comes_From_Source (Expr)))
and then ((Is_Type_Ref (Left_Opnd (Expr))
and then Is_OK_Static_Expression (Right_Opnd (Expr)))
or else
