einfo.ads, einfo.adb (Static_Real_Or_String_Predicate): New function
2014-07-29 Robert Dewar <dewar@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. From-SVN: r213162
This commit is contained in:
parent
60f908dd02
commit
fc3a3f3b7e
|
@ -1,3 +1,16 @@
|
||||||
|
2014-07-29 Robert Dewar <dewar@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 <dewar@adacore.com>
|
2014-07-29 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
* sem_aggr.adb, exp_ch5.adb, sem_ch5.adb, exp_util.adb, einfo.adb,
|
* sem_aggr.adb, exp_ch5.adb, sem_ch5.adb, exp_util.adb, einfo.adb,
|
||||||
|
|
|
@ -223,6 +223,7 @@ package body Einfo is
|
||||||
-- PPC_Wrapper Node25
|
-- PPC_Wrapper Node25
|
||||||
-- Related_Array_Object Node25
|
-- Related_Array_Object Node25
|
||||||
-- Static_Discrete_Predicate List25
|
-- Static_Discrete_Predicate List25
|
||||||
|
-- Static_Real_Or_String_Predicate Node25
|
||||||
-- Task_Body_Procedure Node25
|
-- Task_Body_Procedure Node25
|
||||||
|
|
||||||
-- Dispatch_Table_Wrappers Elist26
|
-- Dispatch_Table_Wrappers Elist26
|
||||||
|
@ -2977,6 +2978,12 @@ package body Einfo is
|
||||||
return List25 (Id);
|
return List25 (Id);
|
||||||
end Static_Discrete_Predicate;
|
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
|
function Status_Flag_Or_Transient_Decl (Id : E) return N is
|
||||||
begin
|
begin
|
||||||
pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
|
pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
|
||||||
|
@ -5767,6 +5774,13 @@ package body Einfo is
|
||||||
Set_List25 (Id, V);
|
Set_List25 (Id, V);
|
||||||
end Set_Static_Discrete_Predicate;
|
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
|
procedure Set_Status_Flag_Or_Transient_Decl (Id : E; V : E) is
|
||||||
begin
|
begin
|
||||||
pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
|
pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
|
||||||
|
@ -9399,13 +9413,12 @@ package body Einfo is
|
||||||
E_Entry_Family =>
|
E_Entry_Family =>
|
||||||
Write_Str ("PPC_Wrapper");
|
Write_Str ("PPC_Wrapper");
|
||||||
|
|
||||||
when E_Enumeration_Type |
|
when Discrete_Kind =>
|
||||||
E_Enumeration_Subtype |
|
|
||||||
E_Modular_Integer_Type |
|
|
||||||
E_Modular_Integer_Subtype |
|
|
||||||
E_Signed_Integer_Subtype =>
|
|
||||||
Write_Str ("Static_Discrete_Predicate");
|
Write_Str ("Static_Discrete_Predicate");
|
||||||
|
|
||||||
|
when Real_Kind =>
|
||||||
|
Write_Str ("Static_Real_Or_String_Predicate");
|
||||||
|
|
||||||
when others =>
|
when others =>
|
||||||
Write_Str ("Field25??");
|
Write_Str ("Field25??");
|
||||||
end case;
|
end case;
|
||||||
|
|
|
@ -3899,7 +3899,7 @@ package Einfo is
|
||||||
|
|
||||||
-- Static_Discrete_Predicate (List25)
|
-- Static_Discrete_Predicate (List25)
|
||||||
-- Defined in discrete types/subtypes with static predicates (with the
|
-- 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
|
-- type/subtype has a static predicate. Points to a list of expression
|
||||||
-- and N_Range nodes that represent the predicate in canonical form. The
|
-- and N_Range nodes that represent the predicate in canonical form. The
|
||||||
-- canonical form has entries sorted in ascending order, with duplicates
|
-- canonical form has entries sorted in ascending order, with duplicates
|
||||||
|
@ -3908,6 +3908,26 @@ package Einfo is
|
||||||
-- are fully analyzed and typed with the base type of the subtype. Note
|
-- 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.
|
-- 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)
|
-- Status_Flag_Or_Transient_Decl (Node15)
|
||||||
-- Defined in variables and constants. Applies to objects that require
|
-- Defined in variables and constants. Applies to objects that require
|
||||||
-- special treatment by the finalization machinery, such as extended
|
-- special treatment by the finalization machinery, such as extended
|
||||||
|
@ -5452,6 +5472,7 @@ package Einfo is
|
||||||
-- Scalar_Range (Node20)
|
-- Scalar_Range (Node20)
|
||||||
-- Delta_Value (Ureal18)
|
-- Delta_Value (Ureal18)
|
||||||
-- Small_Value (Ureal21)
|
-- Small_Value (Ureal21)
|
||||||
|
-- Static_Real_Or_String_Predicate (Node25)
|
||||||
-- Has_Machine_Radix_Clause (Flag83)
|
-- Has_Machine_Radix_Clause (Flag83)
|
||||||
-- Machine_Radix_10 (Flag84)
|
-- Machine_Radix_10 (Flag84)
|
||||||
-- Aft_Value (synth)
|
-- Aft_Value (synth)
|
||||||
|
@ -5557,6 +5578,7 @@ package Einfo is
|
||||||
-- Float_Rep (Uint10) (Float_Rep_Kind)
|
-- Float_Rep (Uint10) (Float_Rep_Kind)
|
||||||
-- Default_Aspect_Value (Node19) (base type only)
|
-- Default_Aspect_Value (Node19) (base type only)
|
||||||
-- Scalar_Range (Node20)
|
-- Scalar_Range (Node20)
|
||||||
|
-- Static_Real_Or_String_Predicate (Node25)
|
||||||
-- Machine_Emax_Value (synth)
|
-- Machine_Emax_Value (synth)
|
||||||
-- Machine_Emin_Value (synth)
|
-- Machine_Emin_Value (synth)
|
||||||
-- Machine_Mantissa_Value (synth)
|
-- Machine_Mantissa_Value (synth)
|
||||||
|
@ -5777,6 +5799,7 @@ package Einfo is
|
||||||
-- Delta_Value (Ureal18)
|
-- Delta_Value (Ureal18)
|
||||||
-- Default_Aspect_Value (Node19) (base type only)
|
-- Default_Aspect_Value (Node19) (base type only)
|
||||||
-- Scalar_Range (Node20)
|
-- Scalar_Range (Node20)
|
||||||
|
-- Static_Real_Or_String_Predicate (Node25)
|
||||||
-- Small_Value (Ureal21)
|
-- Small_Value (Ureal21)
|
||||||
-- Has_Small_Clause (Flag67)
|
-- Has_Small_Clause (Flag67)
|
||||||
-- Aft_Value (synth)
|
-- Aft_Value (synth)
|
||||||
|
@ -6048,6 +6071,7 @@ package Einfo is
|
||||||
-- E_String_Subtype
|
-- E_String_Subtype
|
||||||
-- First_Index (Node17)
|
-- First_Index (Node17)
|
||||||
-- Component_Type (Node20) (base type only)
|
-- Component_Type (Node20) (base type only)
|
||||||
|
-- Static_Real_Or_String_Predicate (Node25)
|
||||||
-- Is_Constrained (Flag12)
|
-- Is_Constrained (Flag12)
|
||||||
-- Next_Index (synth)
|
-- Next_Index (synth)
|
||||||
-- Number_Dimensions (synth)
|
-- Number_Dimensions (synth)
|
||||||
|
@ -6791,6 +6815,7 @@ package Einfo is
|
||||||
function Static_Elaboration_Desired (Id : E) return B;
|
function Static_Elaboration_Desired (Id : E) return B;
|
||||||
function Static_Initialization (Id : E) return N;
|
function Static_Initialization (Id : E) return N;
|
||||||
function Static_Discrete_Predicate (Id : E) return S;
|
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 Status_Flag_Or_Transient_Decl (Id : E) return E;
|
||||||
function Storage_Size_Variable (Id : E) return E;
|
function Storage_Size_Variable (Id : E) return E;
|
||||||
function Stored_Constraint (Id : E) return L;
|
function Stored_Constraint (Id : E) return L;
|
||||||
|
@ -7425,6 +7450,7 @@ package Einfo is
|
||||||
procedure Set_Static_Elaboration_Desired (Id : E; V : B);
|
procedure Set_Static_Elaboration_Desired (Id : E; V : B);
|
||||||
procedure Set_Static_Initialization (Id : E; V : N);
|
procedure Set_Static_Initialization (Id : E; V : N);
|
||||||
procedure Set_Static_Discrete_Predicate (Id : E; V : S);
|
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_Status_Flag_Or_Transient_Decl (Id : E; V : E);
|
||||||
procedure Set_Storage_Size_Variable (Id : E; V : E);
|
procedure Set_Storage_Size_Variable (Id : E; V : E);
|
||||||
procedure Set_Stored_Constraint (Id : E; V : L);
|
procedure Set_Stored_Constraint (Id : E; V : L);
|
||||||
|
@ -8209,6 +8235,7 @@ package Einfo is
|
||||||
pragma Inline (Static_Elaboration_Desired);
|
pragma Inline (Static_Elaboration_Desired);
|
||||||
pragma Inline (Static_Initialization);
|
pragma Inline (Static_Initialization);
|
||||||
pragma Inline (Static_Discrete_Predicate);
|
pragma Inline (Static_Discrete_Predicate);
|
||||||
|
pragma Inline (Static_Real_Or_String_Predicate);
|
||||||
pragma Inline (Status_Flag_Or_Transient_Decl);
|
pragma Inline (Status_Flag_Or_Transient_Decl);
|
||||||
pragma Inline (Storage_Size_Variable);
|
pragma Inline (Storage_Size_Variable);
|
||||||
pragma Inline (Stored_Constraint);
|
pragma Inline (Stored_Constraint);
|
||||||
|
@ -8642,6 +8669,7 @@ package Einfo is
|
||||||
pragma Inline (Set_Static_Elaboration_Desired);
|
pragma Inline (Set_Static_Elaboration_Desired);
|
||||||
pragma Inline (Set_Static_Initialization);
|
pragma Inline (Set_Static_Initialization);
|
||||||
pragma Inline (Set_Static_Discrete_Predicate);
|
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_Status_Flag_Or_Transient_Decl);
|
||||||
pragma Inline (Set_Storage_Size_Variable);
|
pragma Inline (Set_Storage_Size_Variable);
|
||||||
pragma Inline (Set_Stored_Constraint);
|
pragma Inline (Set_Stored_Constraint);
|
||||||
|
|
|
@ -8002,10 +8002,16 @@ package body Sem_Ch13 is
|
||||||
-- yes even if we have an explicit Dynamic_Predicate present.
|
-- yes even if we have an explicit Dynamic_Predicate present.
|
||||||
|
|
||||||
declare
|
declare
|
||||||
PS : constant Boolean := Is_Predicate_Static (Expr, Object_Name);
|
PS : Boolean;
|
||||||
EN : Node_Id;
|
EN : Node_Id;
|
||||||
|
|
||||||
begin
|
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
|
-- Case where we have a predicate-static aspect
|
||||||
|
|
||||||
if PS then
|
if PS then
|
||||||
|
@ -8033,6 +8039,11 @@ package body Sem_Ch13 is
|
||||||
if No (Static_Discrete_Predicate (Typ)) then
|
if No (Static_Discrete_Predicate (Typ)) then
|
||||||
Set_Has_Static_Predicate (Typ, False);
|
Set_Has_Static_Predicate (Typ, False);
|
||||||
end if;
|
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;
|
end if;
|
||||||
|
|
||||||
-- Case of dynamic predicate (expression is not predicate-static)
|
-- Case of dynamic predicate (expression is not predicate-static)
|
||||||
|
@ -8060,14 +8071,13 @@ package body Sem_Ch13 is
|
||||||
-- Now post appropriate message
|
-- Now post appropriate message
|
||||||
|
|
||||||
if Has_Static_Predicate_Aspect (Typ) then
|
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
|
Error_Msg_F
|
||||||
("expression is not predicate-static (RM 4.3.2(16-22))",
|
("expression is not predicate-static (RM 4.3.2(16-22))",
|
||||||
EN);
|
EN);
|
||||||
else
|
else
|
||||||
Error_Msg_FE
|
Error_Msg_F
|
||||||
("static predicate not allowed for non-scalar type&",
|
("static predicate requires scalar or string type", EN);
|
||||||
EN, Typ);
|
|
||||||
end if;
|
end if;
|
||||||
end if;
|
end if;
|
||||||
end if;
|
end if;
|
||||||
|
@ -10362,6 +10372,9 @@ package body Sem_Ch13 is
|
||||||
-- Is_Predicate_Static --
|
-- 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
|
function Is_Predicate_Static
|
||||||
(Expr : Node_Id;
|
(Expr : Node_Id;
|
||||||
Nam : Name_Id) return Boolean
|
Nam : Name_Id) return Boolean
|
||||||
|
@ -10462,12 +10475,6 @@ package body Sem_Ch13 is
|
||||||
-- Start of processing for Is_Predicate_Static
|
-- Start of processing for Is_Predicate_Static
|
||||||
|
|
||||||
begin
|
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
|
-- Predicate_Static means one of the following holds. Numbers are the
|
||||||
-- corresponding paragraph numbers in (RM 3.2.4(16-22)).
|
-- corresponding paragraph numbers in (RM 3.2.4(16-22)).
|
||||||
|
|
||||||
|
@ -10502,7 +10509,20 @@ package body Sem_Ch13 is
|
||||||
-- operand is the current instance, and the other is a static
|
-- operand is the current instance, and the other is a static
|
||||||
-- expression.
|
-- 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
|
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_Type_Ref (Left_Opnd (Expr))
|
||||||
and then Is_OK_Static_Expression (Right_Opnd (Expr)))
|
and then Is_OK_Static_Expression (Right_Opnd (Expr)))
|
||||||
or else
|
or else
|
||||||
|
|
|
@ -227,6 +227,16 @@ package body Sem_Eval is
|
||||||
-- this is an illegality if N is static, and should generate a warning
|
-- this is an illegality if N is static, and should generate a warning
|
||||||
-- otherwise.
|
-- 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);
|
procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
|
||||||
-- N and Exp are nodes representing an expression, Exp is known to raise
|
-- 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.
|
-- CE. N is rewritten in term of Exp in the optimal way.
|
||||||
|
@ -339,23 +349,36 @@ package body Sem_Eval is
|
||||||
-- an explicitly specified Dynamic_Predicate whose expression met the
|
-- an explicitly specified Dynamic_Predicate whose expression met the
|
||||||
-- rules for being predicate-static).
|
-- 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
|
if Is_Real_Type (Typ) then
|
||||||
return;
|
if Real_Or_String_Static_Predicate_Matches
|
||||||
end if;
|
(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
|
elsif Is_String_Type (Typ) then
|
||||||
Error_Msg_N ("??real predicate not applied", Expr);
|
if Real_Or_String_Static_Predicate_Matches
|
||||||
return;
|
(Val => Expr_Value_S (Expr),
|
||||||
end if;
|
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
|
else
|
||||||
return;
|
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;
|
end if;
|
||||||
|
|
||||||
-- Here we know that the predicate will fail
|
-- Here we know that the predicate will fail
|
||||||
|
@ -3052,6 +3075,10 @@ package body Sem_Eval is
|
||||||
-- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
|
-- 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.
|
-- 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
|
procedure Eval_Relational_Op (N : Node_Id) is
|
||||||
Left : constant Node_Id := Left_Opnd (N);
|
Left : constant Node_Id := Left_Opnd (N);
|
||||||
Right : constant Node_Id := Right_Opnd (N);
|
Right : constant Node_Id := Right_Opnd (N);
|
||||||
|
@ -3289,9 +3316,16 @@ package body Sem_Eval is
|
||||||
|
|
||||||
-- Only comparisons of scalars can give static results. In
|
-- Only comparisons of scalars can give static results. In
|
||||||
-- particular, comparisons of strings never yield a static
|
-- 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;
|
Is_Static_Expression := False;
|
||||||
Set_Is_Static_Expression (N, False);
|
Set_Is_Static_Expression (N, False);
|
||||||
end if;
|
end if;
|
||||||
|
@ -3307,9 +3341,8 @@ package body Sem_Eval is
|
||||||
Otype := Find_Universal_Operator_Type (N);
|
Otype := Find_Universal_Operator_Type (N);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- For static real type expressions, we cannot use
|
-- For static real type expressions, do not use Compile_Time_Compare
|
||||||
-- Compile_Time_Compare since it worries about run-time
|
-- since it worries about run-time results which are not exact.
|
||||||
-- results which are not exact.
|
|
||||||
|
|
||||||
if Is_Static_Expression and then Is_Real_Type (Typ) then
|
if Is_Static_Expression and then Is_Real_Type (Typ) then
|
||||||
declare
|
declare
|
||||||
|
@ -5322,6 +5355,112 @@ package body Sem_Eval is
|
||||||
end if;
|
end if;
|
||||||
end Predicates_Match;
|
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 --
|
-- Rewrite_In_Raise_CE --
|
||||||
-------------------------
|
-------------------------
|
||||||
|
|
Loading…
Reference in New Issue