-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Sem_Cat; use Sem_Cat;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Elab; use Sem_Elab;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
-- a subexpression is resolved and is therefore accomplished in a bottom
-- up fashion. The flags are synthesized using the following approach.
- -- Is_Static_Expression is determined by following the detailed rules
- -- in RM 4.9(4-14). This involves testing the Is_Static_Expression
- -- flag of the operands in many cases.
+ -- Is_Static_Expression is determined by following the rules in
+ -- RM-4.9. This involves testing the Is_Static_Expression flag of
+ -- the operands in many cases.
- -- Raises_Constraint_Error is set if any of the operands have the flag
- -- set or if an attempt to compute the value of the current expression
- -- results in detection of a runtime constraint error.
-
- -- As described in the spec, the requirement is that Is_Static_Expression
- -- be accurately set, and in addition for nodes for which this flag is set,
- -- Raises_Constraint_Error must also be set. Furthermore a node which has
- -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the
- -- requirement is that the expression value must be precomputed, and the
- -- node is either a literal, or the name of a constant entity whose value
- -- is a static expression.
+ -- Raises_Constraint_Error is usually set if any of the operands have
+ -- the flag set or if an attempt to compute the value of the current
+ -- expression results in Constraint_Error.
-- The general approach is as follows. First compute Is_Static_Expression.
-- If the node is not static, then the flag is left off in the node and
-- we are all done. Otherwise for a static node, we test if any of the
- -- operands will raise constraint error, and if so, propagate the flag
+ -- operands will raise Constraint_Error, and if so, propagate the flag
-- Raises_Constraint_Error to the result node and we are done (since the
-- error was already posted at a lower level).
-- For the case of a static node whose operands do not raise constraint
-- error, we attempt to evaluate the node. If this evaluation succeeds,
-- then the node is replaced by the result of this computation. If the
- -- evaluation raises constraint error, then we rewrite the node with
+ -- evaluation raises Constraint_Error, then we rewrite the node with
-- Apply_Compile_Time_Constraint_Error to raise the exception and also
-- to post appropriate error messages.
-- Used to convert unsigned (modular) values for folding logical ops
-- The following declarations are used to maintain a cache of nodes that
- -- have compile time known values. The cache is maintained only for
+ -- have compile-time-known values. The cache is maintained only for
-- discrete types (the most common case), and is populated by calls to
-- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
-- since it is possible for the status to change (in particular it is
- -- possible for a node to get replaced by a constraint error node).
+ -- possible for a node to get replaced by a Constraint_Error node).
CV_Bits : constant := 5;
-- Number of low order bits of Node_Id value used to reference entries
-- Range membership may either be statically known to be in range or out
-- of range, or not statically known. Used for Test_In_Range below.
+ Checking_For_Potentially_Static_Expression : Boolean := False;
+ -- Global flag that is set True during Analyze_Static_Expression_Function
+ -- in order to verify that the result expression of a static expression
+ -- function is a potentially static function (see RM202x 6.8(5.3)).
+
-----------------------
-- Local Subprograms --
-----------------------
-- result is No_Match, then it continues and checks the next element. If
-- the result is Match or Non_Static, this result is immediately given
-- as the result without checking the rest of the list. Expr can be of
- -- discrete, real, or string type and must be a compile time known value
+ -- discrete, real, or string type and must be a compile-time-known value
-- (it is an error to make the call if these conditions are not met).
+ procedure Eval_Intrinsic_Call (N : Node_Id; E : Entity_Id);
+ -- Evaluate a call N to an intrinsic subprogram E.
+
+ function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
+ -- Check whether an arithmetic operation with universal operands which is a
+ -- rewritten function call with an explicit scope indication is ambiguous:
+ -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
+ -- type declared in P and the context does not impose a type on the result
+ -- (e.g. in the expression of a type conversion). If ambiguous, emit an
+ -- error and return Empty, else return the result type of the operator.
+
+ procedure Fold_Dummy (N : Node_Id; Typ : Entity_Id);
+ -- Rewrite N as a constant dummy value in the relevant type if possible.
+
+ procedure Fold_Shift
+ (N : Node_Id;
+ Left : Node_Id;
+ Right : Node_Id;
+ Op : Node_Kind;
+ Static : Boolean := False;
+ Check_Elab : Boolean := False);
+ -- Rewrite N as the result of evaluating Left <shift op> Right if possible.
+ -- Op represents the shift operation.
+ -- Static indicates whether the resulting node should be marked static.
+ -- Check_Elab indicates whether checks for elaboration calls should be
+ -- inserted when relevant.
+
function From_Bits (B : Bits; T : Entity_Id) return Uint;
-- Converts a bit string of length B'Length to a Uint value to be used for
-- a target of type T, which is a modular type. This procedure includes the
- -- necessary reduction by the modulus in the case of a non-binary modulus
+ -- necessary reduction by the modulus in the case of a nonbinary modulus
-- (for a binary modulus, the bit string is the right length any way so all
-- is well).
- function Is_Static_Choice (Choice : Node_Id) return Boolean;
- -- Given a choice (from a case expression or membership test), returns
- -- True if the choice is static. No test is made for raising of constraint
- -- error, so this function is used only for legality tests.
-
- function Is_Static_Choice_List (Choices : List_Id) return Boolean;
- -- Given a choice list (from a case expression or membership test), return
- -- True if all choices are static in the sense of Is_Static_Choice.
+ function Get_String_Val (N : Node_Id) return Node_Id;
+ -- Given a tree node for a folded string or character value, returns the
+ -- corresponding string literal or character literal (one of the two must
+ -- be available, or the operand would not have been marked as foldable in
+ -- the earlier analysis of the operation).
function Is_OK_Static_Choice (Choice : Node_Id) return Boolean;
-- Given a choice (from a case expression or membership test), returns
-- Given a choice list (from a case expression or membership test), return
-- True if all choices are static in the sense of Is_OK_Static_Choice.
+ function Is_Static_Choice (Choice : Node_Id) return Boolean;
+ -- Given a choice (from a case expression or membership test), returns
+ -- True if the choice is static. No test is made for raising of constraint
+ -- error, so this function is used only for legality tests.
+
+ function Is_Static_Choice_List (Choices : List_Id) return Boolean;
+ -- Given a choice list (from a case expression or membership test), return
+ -- True if all choices are static in the sense of Is_Static_Choice.
+
function Is_Static_Range (N : Node_Id) return Boolean;
-- Determine if range is static, as defined in RM 4.9(26). The only allowed
-- argument is an N_Range node (but note that the semantic analysis of
-- raise Constraint_Error or not. Used for checking whether expressions are
-- static in the 4.9 sense (without worrying about exceptions).
- function Get_String_Val (N : Node_Id) return Node_Id;
- -- Given a tree node for a folded string or character value, returns the
- -- corresponding string literal or character literal (one of the two must
- -- be available, or the operand would not have been marked as foldable in
- -- the earlier analysis of the operation).
-
function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
-- Bits represents the number of bits in an integer value to be computed
-- (but the value has not been computed yet). If this value in Bits is
procedure Out_Of_Range (N : Node_Id);
-- This procedure is called if it is determined that node N, which appears
- -- in a non-static context, is a compile time known value which is outside
+ -- in a non-static context, is a compile-time-known value which is outside
-- its range, i.e. the range of Etype. This is used in contexts where
-- this is an illegality if N is static, and should generate a warning
-- otherwise.
-- used for producing the result of the static evaluation of the
-- logical operators
- function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
- -- Check whether an arithmetic operation with universal operands which is a
- -- rewritten function call with an explicit scope indication is ambiguous:
- -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
- -- type declared in P and the context does not impose a type on the result
- -- (e.g. in the expression of a type conversion). If ambiguous, emit an
- -- error and return Empty, else return the result type of the operator.
-
procedure Test_Expression_Is_Foldable
(N : Node_Id;
Op1 : Node_Id;
-- If either operand is Any_Type then propagate it to result to prevent
-- cascaded errors.
--
- -- If some operand raises constraint error, then replace the node N
- -- with the raise constraint error node. This replacement inherits the
+ -- If some operand raises Constraint_Error, then replace the node N
+ -- with the raise Constraint_Error node. This replacement inherits the
-- Is_Static_Expression flag from the operands.
procedure Test_Expression_Is_Foldable
-----------------------------------------------
procedure Check_Expression_Against_Static_Predicate
- (Expr : Node_Id;
- Typ : Entity_Id)
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Static_Failure_Is_Error : Boolean := False)
is
begin
-- Nothing to do if expression is not known at compile time, or the
-- Here we have a static predicate (note that it could have arisen from
-- an explicitly specified Dynamic_Predicate whose expression met the
- -- rules for being predicate-static).
+ -- rules for being predicate-static). If the expression is known at
+ -- compile time and obeys the predicate, then it is static and must be
+ -- labeled as such, which matters e.g. for case statements. The original
+ -- expression may be a type conversion of a variable with a known value,
+ -- which might otherwise not be marked static.
-- Case of real static predicate
(Val => Make_Real_Literal (Sloc (Expr), Expr_Value_R (Expr)),
Typ => Typ)
then
+ Set_Is_Static_Expression (Expr);
return;
end if;
if Real_Or_String_Static_Predicate_Matches
(Val => Expr_Value_S (Expr), Typ => Typ)
then
+ Set_Is_Static_Expression (Expr);
return;
end if;
-- If static predicate matches, nothing to do
if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then
+ Set_Is_Static_Expression (Expr);
return;
end if;
end if;
-- Here we know that the predicate will fail
-- Special case of static expression failing a predicate (other than one
- -- that was explicitly specified with a Dynamic_Predicate aspect). This
- -- is the case where the expression is no longer considered static.
+ -- that was explicitly specified with a Dynamic_Predicate aspect). If
+ -- the expression comes from a qualified_expression or type_conversion
+ -- this is an error (Static_Failure_Is_Error); otherwise we only issue
+ -- a warning and the expression is no longer considered static.
if Is_Static_Expression (Expr)
and then not Has_Dynamic_Predicate_Aspect (Typ)
then
- Error_Msg_NE
- ("??static expression fails static predicate check on &",
- Expr, Typ);
- Error_Msg_N
- ("\??expression is no longer considered static", Expr);
- Set_Is_Static_Expression (Expr, False);
+ if Static_Failure_Is_Error then
+ Error_Msg_NE
+ ("static expression fails static predicate check on &",
+ Expr, Typ);
+
+ else
+ Error_Msg_NE
+ ("??static expression fails static predicate check on &",
+ Expr, Typ);
+ Error_Msg_N
+ ("\??expression is no longer considered static", Expr);
+
+ Set_Is_Static_Expression (Expr, False);
+ end if;
-- In all other cases, this is just a warning that a test will fail.
-- It does not matter if the expression is static or not, or if the
else
Error_Msg_NE
("??expression fails predicate check on &", Expr, Typ);
+
+ -- Force a check here, which is potentially a redundant check, but
+ -- this ensures a check will be done in cases where the expression
+ -- is folded, and since this is definitely a failure, extra checks
+ -- are OK.
+
+ if Predicate_Enabled (Typ) then
+ Insert_Action (Expr,
+ Make_Predicate_Check
+ (Typ, Duplicate_Subexpr (Expr)), Suppress => All_Checks);
+ end if;
end if;
end Check_Expression_Against_Static_Predicate;
-- that an infinity will result.
if not Is_Static_Expression (N) then
- if Is_Floating_Point_Type (T)
- and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
- then
- Error_Msg_N
- ("??float value out of range, infinity will be generated", N);
+ if Is_Floating_Point_Type (T) then
+ if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
+ Error_Msg_N
+ ("??float value out of range, infinity will be generated", N);
+
+ -- The literal may be the result of constant-folding of a non-
+ -- static subexpression of a larger expression (e.g. a conversion
+ -- of a non-static variable whose value happens to be known). At
+ -- this point we must reduce the value of the subexpression to a
+ -- machine number (RM 4.9 (38/2)).
+
+ elsif Nkind (N) = N_Real_Literal
+ and then Nkind (Parent (N)) in N_Subexpr
+ then
+ Rewrite (N, New_Copy (N));
+ Set_Realval
+ (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
+ end if;
end if;
return;
-- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
-- and SGI/Irix.
+ -- This conversion is always done by GNATprove on real literals in
+ -- non-static expressions, by calling Check_Non_Static_Context from
+ -- gnat2why, as GNATprove cannot do the conversion later contrary
+ -- to gigi. The frontend computes the information about which
+ -- expressions are static, which is used by gnat2why to call
+ -- Check_Non_Static_Context on exactly those real literals that are
+ -- not subexpressions of static expressions.
+
if Nkind (N) = N_Real_Literal
and then not Is_Machine_Number (N)
and then not Is_Generic_Type (Etype (N))
-- differences in rounding between static and non-static
-- expressions. AI-100 specifies that the effect of such rounding
-- is implementation dependent, and in GNAT we round to nearest
- -- even to match the run-time behavior.
+ -- even to match the run-time behavior. Note that this applies
+ -- to floating point literals, not fixed points ones, even though
+ -- their compiler representation is also as a universal real.
Set_Realval
(N, Machine (Base_Type (T), Realval (N), Round_Even, N));
+ Set_Is_Machine_Number (N);
end if;
- Set_Is_Machine_Number (N);
end if;
-- Check for out of range universal integer. This is a non-static
-- called in contexts like the expression of a number declaration where
-- we certainly want to allow out of range values.
+ -- We inhibit the warning when expansion is disabled, because the
+ -- preanalysis of a range of a 64-bit modular type may appear to
+ -- violate the constraint on non-static Universal_Integer. If there
+ -- is a true overflow it will be diagnosed during full analysis.
+
if Etype (N) = Universal_Integer
and then Nkind (N) = N_Integer_Literal
and then Nkind (Parent (N)) in N_Subexpr
+ and then Expander_Active
and then
(Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
or else
elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
Out_Of_Range (N);
- -- Give warning if outside subtype (where one or both of the bounds of
- -- the subtype is static). This warning is omitted if the expression
- -- appears in a range that could be null (warnings are handled elsewhere
- -- for this case).
+ -- Give a warning or error on the value outside the subtype. A warning
+ -- is omitted if the expression appears in a range that could be null
+ -- (warnings are handled elsewhere for this case).
elsif T /= Base_Type (T) and then Nkind (Parent (N)) /= N_Range then
if Is_In_Range (N, T, Assume_Valid => True) then
null;
elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
- Apply_Compile_Time_Constraint_Error
- (N, "value not in range of}<<", CE_Range_Check_Failed);
+ -- Ignore out of range values for System.Priority in CodePeer
+ -- mode since the actual target compiler may provide a wider
+ -- range.
+
+ if CodePeer_Mode and then Is_RTE (T, RE_Priority) then
+ Set_Do_Range_Check (N, False);
+
+ -- Determine if the out-of-range violation constitutes a warning
+ -- or an error based on context, according to RM 4.9 (34/3).
+
+ elsif Nkind (Original_Node (N)) in
+ N_Type_Conversion | N_Qualified_Expression
+ and then Comes_From_Source (Original_Node (N))
+ then
+ Apply_Compile_Time_Constraint_Error
+ (N, "value not in range of}", CE_Range_Check_Failed);
+ else
+ Apply_Compile_Time_Constraint_Error
+ (N, "value not in range of}<<", CE_Range_Check_Failed);
+ end if;
elsif Checks_On then
Enable_Range_Check (N);
end if;
end Check_String_Literal_Length;
+ --------------------------------------------
+ -- Checking_Potentially_Static_Expression --
+ --------------------------------------------
+
+ function Checking_Potentially_Static_Expression return Boolean is
+ begin
+ return Checking_For_Potentially_Static_Expression;
+ end Checking_Potentially_Static_Expression;
+
--------------------
-- Choice_Matches --
--------------------
Set_Raises_Constraint_Error (Choice);
return Non_Static;
- -- Discrete type case
+ -- When the choice denotes a subtype with a static predictate, check the
+ -- expression against the predicate values. Different procedures apply
+ -- to discrete and non-discrete types.
+
+ elsif (Nkind (Choice) = N_Subtype_Indication
+ or else (Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))))
+ and then Has_Predicates (Etype (Choice))
+ and then Has_Static_Predicate (Etype (Choice))
+ then
+ if Is_Discrete_Type (Etype (Choice)) then
+ return
+ Choices_Match
+ (Expr, Static_Discrete_Predicate (Etype (Choice)));
+
+ elsif Real_Or_String_Static_Predicate_Matches (Expr, Etype (Choice))
+ then
+ return Match;
+
+ else
+ return No_Match;
+ end if;
+
+ -- Discrete type case only
- elsif Is_Discrete_Type (Etype (Expr)) then
+ elsif Is_Discrete_Type (Etyp) then
Val := Expr_Value (Expr);
if Nkind (Choice) = N_Range then
end if;
elsif Nkind (Choice) = N_Subtype_Indication
- or else
- (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
+ or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
if Val >= Expr_Value (Type_Low_Bound (Etype (Choice)))
and then
end if;
end if;
- -- Real type case
+ -- Real type case
- elsif Is_Real_Type (Etype (Expr)) then
+ elsif Is_Real_Type (Etyp) then
ValR := Expr_Value_R (Expr);
if Nkind (Choice) = N_Range then
end if;
elsif Nkind (Choice) = N_Subtype_Indication
- or else
- (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
+ or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
if ValR >= Expr_Value_R (Type_Low_Bound (Etype (Choice)))
and then
end if;
end if;
- -- String type cases
+ -- String type cases
else
- pragma Assert (Is_String_Type (Etype (Expr)));
+ pragma Assert (Is_String_Type (Etyp));
ValS := Expr_Value_S (Expr);
if Nkind (Choice) = N_Subtype_Indication
- or else
- (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
+ or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
if not Is_Constrained (Etype (Choice)) then
return Match;
Assume_Valid : Boolean;
Rec : Boolean := False) return Compare_Result
is
- Ltyp : Entity_Id := Underlying_Type (Etype (L));
- Rtyp : Entity_Id := Underlying_Type (Etype (R));
- -- These get reset to the base type for the case of entities where
- -- Is_Known_Valid is not set. This takes care of handling possible
- -- invalid representations using the value of the base type, in
- -- accordance with RM 13.9.1(10).
+ Ltyp : Entity_Id := Etype (L);
+ Rtyp : Entity_Id := Etype (R);
Discard : aliased Uint;
function Is_Same_Value (L, R : Node_Id) return Boolean;
-- Returns True iff L and R represent expressions that definitely have
- -- identical (but not necessarily compile time known) values Indeed the
+ -- identical (but not necessarily compile-time-known) values Indeed the
-- caller is expected to have already dealt with the cases of compile
-- time known values, so these are not tested here.
V := UI_Negate (Intval (Right_Opnd (N)));
return;
- elsif Nkind (N) = N_Attribute_Reference then
+ elsif Nkind (N) = N_Attribute_Reference then
if Attribute_Name (N) = Name_Succ then
R := First (Expressions (N));
V := Uint_1;
-- Fixup only required for First/Last attribute reference
if Nkind (N) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (N), Name_First, Name_Last)
+ and then Attribute_Name (N) in Name_First | Name_Last
then
Xtyp := Etype (Prefix (N));
Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
for J in 2 .. Subs loop
- Indx := Next_Index (Indx);
+ Next_Index (Indx);
end loop;
end if;
(Is_Known_Valid (Entity (Opnd))
or else Ekind (Entity (Opnd)) = E_In_Parameter
or else
- (Ekind (Entity (Opnd)) in Object_Kind
+ (Is_Object (Entity (Opnd))
and then Present (Current_Value (Entity (Opnd))))))
or else Is_OK_Static_Expression (Opnd);
end Is_Known_Valid_Operand;
Lf : constant Node_Id := Compare_Fixup (L);
Rf : constant Node_Id := Compare_Fixup (R);
+ function Is_Rewritten_Loop_Entry (N : Node_Id) return Boolean;
+ -- An attribute reference to Loop_Entry may have been rewritten into
+ -- its prefix as a way to avoid generating a constant for that
+ -- attribute when the corresponding pragma is ignored. These nodes
+ -- should be ignored when deciding if they can be equal to one
+ -- another.
+
function Is_Same_Subscript (L, R : List_Id) return Boolean;
-- L, R are the Expressions values from two attribute nodes for First
-- or Last attributes. Either may be set to No_List if no expressions
-- expressions represent the same subscript (note one case is where
-- one subscript is missing and the other is explicitly set to 1).
+ -----------------------------
+ -- Is_Rewritten_Loop_Entry --
+ -----------------------------
+
+ function Is_Rewritten_Loop_Entry (N : Node_Id) return Boolean is
+ Orig_N : constant Node_Id := Original_Node (N);
+ begin
+ return Orig_N /= N
+ and then Nkind (Orig_N) = N_Attribute_Reference
+ and then Get_Attribute_Id (Attribute_Name (Orig_N)) =
+ Attribute_Loop_Entry;
+ end Is_Rewritten_Loop_Entry;
+
-----------------------
-- Is_Same_Subscript --
-----------------------
-- Start of processing for Is_Same_Value
begin
- -- Values are the same if they refer to the same entity and the
- -- entity is non-volatile. This does not however apply to Float
- -- types, since we may have two NaN values and they should never
- -- compare equal.
+ -- Loop_Entry nodes rewritten into their prefix inside ignored
+ -- pragmas should never lead to a decision of equality.
- -- If the entity is a discriminant, the two expressions may be bounds
- -- of components of objects of the same discriminated type. The
- -- values of the discriminants are not static, and therefore the
- -- result is unknown.
+ if Is_Rewritten_Loop_Entry (Lf)
+ or else Is_Rewritten_Loop_Entry (Rf)
+ then
+ return False;
- -- It would be better to comment individual branches of this test ???
+ -- Values are the same if they refer to the same entity and the
+ -- entity is nonvolatile.
- if Nkind_In (Lf, N_Identifier, N_Expanded_Name)
- and then Nkind_In (Rf, N_Identifier, N_Expanded_Name)
+ elsif Nkind (Lf) in N_Identifier | N_Expanded_Name
+ and then Nkind (Rf) in N_Identifier | N_Expanded_Name
and then Entity (Lf) = Entity (Rf)
+
+ -- If the entity is a discriminant, the two expressions may be
+ -- bounds of components of objects of the same discriminated type.
+ -- The values of the discriminants are not static, and therefore
+ -- the result is unknown.
+
and then Ekind (Entity (Lf)) /= E_Discriminant
and then Present (Entity (Lf))
+
+ -- This does not however apply to Float types, since we may have
+ -- two NaN values and they should never compare equal.
+
and then not Is_Floating_Point_Type (Etype (L))
and then not Is_Volatile_Reference (L)
and then not Is_Volatile_Reference (R)
then
return True;
- -- Or if they are compile time known and identical
+ -- Or if they are compile-time-known and identical
elsif Compile_Time_Known_Value (Lf)
and then
elsif Nkind (Lf) = N_Attribute_Reference
and then Attribute_Name (Lf) = Attribute_Name (Rf)
- and then Nam_In (Attribute_Name (Lf), Name_First, Name_Last)
- and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name)
- and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name)
+ and then Attribute_Name (Lf) in Name_First | Name_Last
+ and then Nkind (Prefix (Lf)) in N_Identifier | N_Expanded_Name
+ and then Nkind (Prefix (Rf)) in N_Identifier | N_Expanded_Name
and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
then
return Unknown;
end if;
- -- If either operand could raise constraint error, then we cannot
+ -- If either operand could raise Constraint_Error, then we cannot
-- know the result at compile time (since CE may be raised).
if not (Cannot_Raise_Constraint_Error (L)
if L = R then
return EQ;
+ end if;
-- If expressions have no types, then do not attempt to determine if
-- they are the same, since something funny is going on. One case in
-- which this happens is during generic template analysis, when bounds
-- are not fully analyzed.
- elsif No (Ltyp) or else No (Rtyp) then
+ if No (Ltyp) or else No (Rtyp) then
+ return Unknown;
+ end if;
+
+ -- These get reset to the base type for the case of entities where
+ -- Is_Known_Valid is not set. This takes care of handling possible
+ -- invalid representations using the value of the base type, in
+ -- accordance with RM 13.9.1(10).
+
+ Ltyp := Underlying_Type (Ltyp);
+ Rtyp := Underlying_Type (Rtyp);
+
+ -- Same rationale as above, but for Underlying_Type instead of Etype
+
+ if No (Ltyp) or else No (Rtyp) then
return Unknown;
+ end if;
- -- We do not attempt comparisons for packed arrays arrays represented as
+ -- We do not attempt comparisons for packed arrays represented as
-- modular types, where the semantics of comparison is quite different.
- elsif Is_Packed_Array_Impl_Type (Ltyp)
+ if Is_Packed_Array_Impl_Type (Ltyp)
and then Is_Modular_Integer_Type (Ltyp)
then
return Unknown;
return Unknown;
end if;
- -- Case where comparison involves two compile time known values
+ -- Case where comparison involves two compile-time-known values
elsif Compile_Time_Known_Value (L)
and then
return Unknown;
end if;
- -- Replace types by base types for the case of entities which are not
+ -- Replace types by base types for the case of values which are not
-- known to have valid representations. This takes care of properly
-- dealing with invalid representations.
- if not Assume_Valid and then not Assume_No_Invalid_Values then
- if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then
+ if not Assume_Valid then
+ if not (Is_Entity_Name (L)
+ and then (Is_Known_Valid (Entity (L))
+ or else Assume_No_Invalid_Values))
+ then
Ltyp := Underlying_Type (Base_Type (Ltyp));
end if;
- if Is_Entity_Name (R) and then not Is_Known_Valid (Entity (R)) then
+ if not (Is_Entity_Name (R)
+ and then (Is_Known_Valid (Entity (R))
+ or else Assume_No_Invalid_Values))
+ then
Rtyp := Underlying_Type (Base_Type (Rtyp));
end if;
end if;
if Is_Same_Value (Lnode, Rnode) then
if Loffs = Roffs then
return EQ;
- elsif Loffs < Roffs then
- Diff.all := Roffs - Loffs;
- return LT;
- else
- Diff.all := Loffs - Roffs;
- return GT;
+ end if;
+
+ -- When the offsets are not equal, we can go farther only if
+ -- the types are not modular (e.g. X < X + 1 is False if X is
+ -- the largest number).
+
+ if not Is_Modular_Integer_Type (Ltyp)
+ and then not Is_Modular_Integer_Type (Rtyp)
+ then
+ if Loffs < Roffs then
+ Diff.all := Roffs - Loffs;
+ return LT;
+ else
+ Diff.all := Loffs - Roffs;
+ return GT;
+ end if;
end if;
end if;
end;
end if;
-- Next attempt is to see if we have an entity compared with a
- -- compile time known value, where there is a current value
+ -- compile-time-known value, where there is a current value
-- conditional for the entity which can tell us the result.
declare
return False;
end if;
- -- Otherwise check bounds for compile time known
+ -- Otherwise check bounds for compile-time-known
if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
return False;
CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
begin
- -- Never known at compile time if bad type or raises constraint error
+ -- Never known at compile time if bad type or raises Constraint_Error
-- or empty (latter case occurs only as a result of a previous error).
if No (Op) then
end if;
-- If we have an entity name, then see if it is the name of a constant
- -- and if so, test the corresponding constant value, or the name of
- -- an enumeration literal, which is always a constant.
+ -- and if so, test the corresponding constant value, or the name of an
+ -- enumeration literal, which is always a constant.
if Present (Etype (Op)) and then Is_Entity_Name (Op) then
declare
- E : constant Entity_Id := Entity (Op);
- V : Node_Id;
+ Ent : constant Entity_Id := Entity (Op);
+ Val : Node_Id;
begin
- -- Never known at compile time if it is a packed array value.
- -- We might want to try to evaluate these at compile time one
- -- day, but we do not make that attempt now.
+ -- Never known at compile time if it is a packed array value. We
+ -- might want to try to evaluate these at compile time one day,
+ -- but we do not make that attempt now.
if Is_Packed_Array_Impl_Type (Etype (Op)) then
return False;
- end if;
- if Ekind (E) = E_Enumeration_Literal then
+ elsif Ekind (Ent) = E_Enumeration_Literal then
return True;
- elsif Ekind (E) = E_Constant then
- V := Constant_Value (E);
- return Present (V) and then Compile_Time_Known_Value (V);
+ elsif Ekind (Ent) = E_Constant then
+ Val := Constant_Value (Ent);
+
+ if Present (Val) then
+
+ -- Guard against an illegal deferred constant whose full
+ -- view is initialized with a reference to itself. Treat
+ -- this case as a value not known at compile time.
+
+ if Is_Entity_Name (Val) and then Entity (Val) = Ent then
+ return False;
+ else
+ return Compile_Time_Known_Value (Val);
+ end if;
+
+ -- Otherwise, the constant does not have a compile-time-known
+ -- value.
+
+ else
+ return False;
+ end if;
end if;
end;
- -- We have a value, see if it is compile time known
+ -- We have a value, see if it is compile-time-known
else
-- Integer literals are worth storing in the cache
-- Other literals and NULL are known at compile time
- elsif
- Nkind_In (K, N_Character_Literal,
- N_Real_Literal,
- N_String_Literal,
- N_Null)
+ elsif K in
+ N_Character_Literal | N_Real_Literal | N_String_Literal | N_Null
then
return True;
-
- -- Any reference to Null_Parameter is known at compile time. No
- -- other attribute references (that have not already been folded)
- -- are known at compile time.
-
- elsif K = N_Attribute_Reference then
- return Attribute_Name (Op) = Name_Null_Parameter;
end if;
end if;
exception
when others =>
+ -- With debug flag K we will get an exception unless an error has
+ -- already occurred (useful for debugging).
+
+ if Debug_Flag_K then
+ Check_Error_Detected;
+ end if;
+
return False;
end Compile_Time_Known_Value;
end if;
end;
- -- We have a value, see if it is compile time known
+ -- We have a value, see if it is compile-time-known
else
if Compile_Time_Known_Value (Op) then
return True;
+ elsif Nkind (Op) = N_Qualified_Expression then
+ return Compile_Time_Known_Value_Or_Aggr (Expression (Op));
+
-- All other types of values are not known at compile time
else
-- division, rem and mod if the right operand is zero.
if Right_Int = 0 then
+
+ -- When SPARK_Mode is On, force a warning instead of
+ -- an error in that case, as this likely corresponds
+ -- to deactivated code.
+
Apply_Compile_Time_Constraint_Error
(N, "division by zero", CE_Divide_By_Zero,
- Warn => not Stat);
+ Warn => not Stat or SPARK_Mode = On);
Set_Raises_Constraint_Error (N);
return;
-- division, rem and mod if the right operand is zero.
if Right_Int = 0 then
+
+ -- When SPARK_Mode is On, force a warning instead of
+ -- an error in that case, as this likely corresponds
+ -- to deactivated code.
+
Apply_Compile_Time_Constraint_Error
(N, "mod with zero divisor", CE_Divide_By_Zero,
- Warn => not Stat);
+ Warn => not Stat or SPARK_Mode = On);
return;
+
else
Result := Left_Int mod Right_Int;
end if;
-- division, rem and mod if the right operand is zero.
if Right_Int = 0 then
+
+ -- When SPARK_Mode is On, force a warning instead of
+ -- an error in that case, as this likely corresponds
+ -- to deactivated code.
+
Apply_Compile_Time_Constraint_Error
(N, "rem with zero divisor", CE_Divide_By_Zero,
- Warn => not Stat);
+ Warn => not Stat or SPARK_Mode = On);
return;
else
-- Only the latter case is handled here, predefined operators are
-- constant-folded elsewhere.
- -- If the function is itself inherited (see 7423-001) the literal of
- -- the parent type must be explicitly converted to the return type
- -- of the function.
+ -- If the function is itself inherited the literal of the parent type must
+ -- be explicitly converted to the return type of the function.
procedure Eval_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Resolve (N, Typ);
end if;
+
+ elsif Nkind (N) = N_Function_Call
+ and then Is_Entity_Name (Name (N))
+ and then Is_Intrinsic_Subprogram (Entity (Name (N)))
+ then
+ Eval_Intrinsic_Call (N, Entity (Name (N)));
+
+ -- Ada 202x (AI12-0075): If checking for potentially static expressions
+ -- is enabled and we have a call to a static function, substitute a
+ -- static value for the call, to allow folding the expression. This
+ -- supports checking the requirement of RM 6.8(5.3/5) in
+ -- Analyze_Expression_Function.
+
+ elsif Checking_Potentially_Static_Expression
+ and then Is_Static_Function_Call (N)
+ then
+ Fold_Dummy (N, Typ);
end if;
end Eval_Call;
begin
Set_Is_Static_Expression (N, False);
- if not Is_Static_Expression (Expression (N)) then
+ if Error_Posted (Expression (N))
+ or else not Is_Static_Expression (Expression (N))
+ then
Check_Non_Static_Context (Expression (N));
return;
end if;
-- First loop, make sure all the alternatives are static expressions
- -- none of which raise Constraint_Error. We make the constraint error
+ -- none of which raise Constraint_Error. We make the Constraint_Error
-- check because part of the legality condition for a correct static
-- case expression is that the cases are covered, like any other case
-- expression. And we can't do that if any of the conditions raise an
Set_Is_Static_Expression (N);
- -- Now to deal with propagating a possible constraint error
+ -- Now to deal with propagating a possible Constraint_Error
-- If the selecting expression raises CE, propagate and we are done
Left_Str : constant Node_Id := Get_String_Val (Left);
Left_Len : Nat;
Right_Str : constant Node_Id := Get_String_Val (Right);
- Folded_Val : String_Id;
+ Folded_Val : String_Id := No_String;
begin
-- Establish new string literal, and store left operand. We make
-- case of a concatenation of a series of string literals.
if Nkind (Left_Str) = N_String_Literal then
- Left_Len := String_Length (Strval (Left_Str));
+ Left_Len := String_Length (Strval (Left_Str));
-- If the left operand is the empty string, and the right operand
-- is a string literal (the case of "" & "..."), the result is the
begin
-- Enumeration literals are always considered to be constants
- -- and cannot raise constraint error (RM 4.9(22)).
+ -- and cannot raise Constraint_Error (RM 4.9(22)).
if Ekind (Def_Id) = E_Enumeration_Literal then
Set_Is_Static_Expression (N);
return;
end if;
+
+ -- Ada 202x (AI12-0075): If checking for potentially static expressions
+ -- is enabled and we have a reference to a formal parameter of mode in,
+ -- substitute a static value for the reference, to allow folding the
+ -- expression. This supports checking the requirement of RM 6.8(5.3/5)
+ -- in Analyze_Expression_Function.
+
+ elsif Ekind (Def_Id) = E_In_Parameter
+ and then Checking_Potentially_Static_Expression
+ and then Is_Static_Function (Scope (Def_Id))
+ then
+ Fold_Dummy (N, Etype (Def_Id));
end if;
-- Fall through if the name is not static
return;
end if;
- -- If condition raises constraint error then we have already signaled
+ -- If condition raises Constraint_Error then we have already signaled
-- an error, and we just propagate to the result and do not fold.
if Raises_Constraint_Error (Condition) then
end if;
-- Note that it does not matter if the non-result operand raises a
- -- Constraint_Error, but if the result raises constraint error then we
- -- replace the node with a raise constraint error. This will properly
+ -- Constraint_Error, but if the result raises Constraint_Error then we
+ -- replace the node with a raise Constraint_Error. This will properly
-- propagate Raises_Constraint_Error since this flag is set in Result.
if Raises_Constraint_Error (Result) then
-- Similarly if the indexed component appears as the prefix of an
-- attribute we don't want to evaluate it, because at least for
- -- some cases of attributes we need the identify (e.g. Access, Size)
+ -- some cases of attributes we need the identify (e.g. Access, Size).
elsif Nkind (Parent (N)) = N_Attribute_Reference then
return;
if List_Length (Expressions (Arr)) >= Lin then
Elm := Pick (Expressions (Arr), Lin);
- -- If the resulting expression is compile time known,
+ -- If the resulting expression is compile-time-known,
-- then we can rewrite the indexed component with this
-- value, being sure to mark the result as non-static.
-- We also reset the Sloc, in case this generates an
-- the expander that do not correspond to static expressions.
procedure Eval_Integer_Literal (N : Node_Id) is
- T : constant Entity_Id := Etype (N);
-
- function In_Any_Integer_Context return Boolean;
+ function In_Any_Integer_Context (Context : Node_Id) return Boolean;
-- If the literal is resolved with a specific type in a context where
-- the expected type is Any_Integer, there are no range checks on the
-- literal. By the time the literal is evaluated, it carries the type
-- In_Any_Integer_Context --
----------------------------
- function In_Any_Integer_Context return Boolean is
- Par : constant Node_Id := Parent (N);
- K : constant Node_Kind := Nkind (Par);
-
+ function In_Any_Integer_Context (Context : Node_Id) return Boolean is
begin
-- Any_Integer also appears in digits specifications for real types,
-- but those have bounds smaller that those of any integer base type,
-- so we can safely ignore these cases.
- return Nkind_In (K, N_Number_Declaration,
- N_Attribute_Reference,
- N_Attribute_Definition_Clause,
- N_Modular_Type_Definition,
- N_Signed_Integer_Type_Definition);
+ return
+ Nkind (Context) in N_Attribute_Definition_Clause
+ | N_Attribute_Reference
+ | N_Modular_Type_Definition
+ | N_Number_Declaration
+ | N_Signed_Integer_Type_Definition;
end In_Any_Integer_Context;
+ -- Local variables
+
+ Par : constant Node_Id := Parent (N);
+ Typ : constant Entity_Id := Etype (N);
+
-- Start of processing for Eval_Integer_Literal
begin
-
-- If the literal appears in a non-expression context, then it is
-- certainly appearing in a non-static context, so check it. This is
-- actually a redundant check, since Check_Non_Static_Context would
- -- check it, but it seems worth while avoiding the call.
-
- if Nkind (Parent (N)) not in N_Subexpr
- and then not In_Any_Integer_Context
+ -- check it, but it seems worthwhile to optimize out the call.
+
+ -- Additionally, when the literal appears within an if or case
+ -- expression it must be checked as well. However, due to the literal
+ -- appearing within a conditional statement, expansion greatly changes
+ -- the nature of its context and performing some of the checks within
+ -- Check_Non_Static_Context on an expanded literal may lead to spurious
+ -- and misleading warnings.
+
+ if (Nkind (Par) in N_Case_Expression_Alternative | N_If_Expression
+ or else Nkind (Par) not in N_Subexpr)
+ and then (Nkind (Par) not in N_Case_Expression_Alternative
+ | N_If_Expression
+ or else Comes_From_Source (N))
+ and then not In_Any_Integer_Context (Par)
then
Check_Non_Static_Context (N);
end if;
-- Modular integer literals must be in their base range
- if Is_Modular_Integer_Type (T)
- and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
+ if Is_Modular_Integer_Type (Typ)
+ and then Is_Out_Of_Range (N, Base_Type (Typ), Assume_Valid => True)
then
Out_Of_Range (N);
end if;
end Eval_Integer_Literal;
+ -------------------------
+ -- Eval_Intrinsic_Call --
+ -------------------------
+
+ procedure Eval_Intrinsic_Call (N : Node_Id; E : Entity_Id) is
+
+ procedure Eval_Shift (N : Node_Id; E : Entity_Id; Op : Node_Kind);
+ -- Evaluate an intrinsic shift call N on the given subprogram E.
+ -- Op is the kind for the shift node.
+
+ ----------------
+ -- Eval_Shift --
+ ----------------
+
+ procedure Eval_Shift (N : Node_Id; E : Entity_Id; Op : Node_Kind) is
+ Left : constant Node_Id := First_Actual (N);
+ Right : constant Node_Id := Next_Actual (Left);
+ Static : constant Boolean := Is_Static_Function (E);
+
+ begin
+ if Static then
+ if Checking_Potentially_Static_Expression then
+ Fold_Dummy (N, Etype (N));
+ return;
+ end if;
+ end if;
+
+ Fold_Shift
+ (N, Left, Right, Op, Static => Static, Check_Elab => not Static);
+ end Eval_Shift;
+
+ Nam : Name_Id;
+
+ begin
+ -- Nothing to do if the intrinsic is handled by the back end.
+
+ if Present (Interface_Name (E)) then
+ return;
+ end if;
+
+ -- Intrinsic calls as part of a static function is a language extension.
+
+ if Checking_Potentially_Static_Expression
+ and then not Extensions_Allowed
+ then
+ return;
+ end if;
+
+ -- If we have a renaming, expand the call to the original operation,
+ -- which must itself be intrinsic, since renaming requires matching
+ -- conventions and this has already been checked.
+
+ if Present (Alias (E)) then
+ Eval_Intrinsic_Call (N, Alias (E));
+ return;
+ end if;
+
+ -- If the intrinsic subprogram is generic, gets its original name
+
+ if Present (Parent (E))
+ and then Present (Generic_Parent (Parent (E)))
+ then
+ Nam := Chars (Generic_Parent (Parent (E)));
+ else
+ Nam := Chars (E);
+ end if;
+
+ case Nam is
+ when Name_Shift_Left =>
+ Eval_Shift (N, E, N_Op_Shift_Left);
+ when Name_Shift_Right =>
+ Eval_Shift (N, E, N_Op_Shift_Right);
+ when Name_Shift_Right_Arithmetic =>
+ Eval_Shift (N, E, N_Op_Shift_Right_Arithmetic);
+ when others =>
+ null;
+ end case;
+ end Eval_Intrinsic_Call;
+
---------------------
-- Eval_Logical_Op --
---------------------
Right_Int : constant Uint := Expr_Value (Right);
begin
- -- VMS includes bitwise operations on signed types
-
- if Is_Modular_Integer_Type (Etype (N))
- or else Is_VMS_Operator (Entity (N))
- then
+ if Is_Modular_Integer_Type (Etype (N)) then
declare
Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
To_Bits (Right_Int, Right_Bits);
-- Note: should really be able to use array ops instead of
- -- these loops, but they weren't working at the time ???
+ -- these loops, but they break the build with a cryptic error
+ -- during the bind of gnat1 likely due to a wrong computation
+ -- of a date or checksum.
if Nkind (N) = N_Op_And then
for J in Left_Bits'Range loop
-- static subtype (RM 4.9(12)).
procedure Eval_Membership_Op (N : Node_Id) is
- Left : constant Node_Id := Left_Opnd (N);
- Right : constant Node_Id := Right_Opnd (N);
Alts : constant List_Id := Alternatives (N);
+ Choice : constant Node_Id := Right_Opnd (N);
+ Expr : constant Node_Id := Left_Opnd (N);
Result : Match_Result;
begin
-- Ignore if error in either operand, except to make sure that Any_Type
-- is properly propagated to avoid junk cascaded errors.
- if Etype (Left) = Any_Type
- or else (Present (Right) and then Etype (Right) = Any_Type)
+ if Etype (Expr) = Any_Type
+ or else (Present (Choice) and then Etype (Choice) = Any_Type)
then
Set_Etype (N, Any_Type);
return;
end if;
- -- Ignore if types involved have predicates
- -- Is this right for static predicates ???
- -- And what about the alternatives ???
-
- if Present (Predicate_Function (Etype (Left)))
- or else (Present (Right)
- and then Present (Predicate_Function (Etype (Right))))
- then
- return;
- end if;
-
-- If left operand non-static, then nothing to do
- if not Is_Static_Expression (Left) then
+ if not Is_Static_Expression (Expr) then
return;
end if;
-- If choice is non-static, left operand is in non-static context
- if (Present (Right) and then not Is_Static_Choice (Right))
+ if (Present (Choice) and then not Is_Static_Choice (Choice))
or else (Present (Alts) and then not Is_Static_Choice_List (Alts))
then
- Check_Non_Static_Context (Left);
+ Check_Non_Static_Context (Expr);
return;
end if;
Set_Is_Static_Expression (N);
- -- If left operand raises constraint error, propagate and we are done
+ -- If left operand raises Constraint_Error, propagate and we are done
- if Raises_Constraint_Error (Left) then
+ if Raises_Constraint_Error (Expr) then
Set_Raises_Constraint_Error (N, True);
-- See if we match
else
- if Present (Right) then
- Result := Choice_Matches (Left, Right);
+ if Present (Choice) then
+ Result := Choice_Matches (Expr, Choice);
else
- Result := Choices_Match (Left, Alts);
+ Result := Choices_Match (Expr, Alts);
end if;
-- If result is Non_Static, it means that we raise Constraint_Error,
-- Eval_Op_Not --
-----------------
- -- The not operation is a static functions, so the result is potentially
+ -- The not operation is a static function, so the result is potentially
-- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
procedure Eval_Op_Not (N : Node_Id) is
begin
-- Negation is equivalent to subtracting from the modulus minus one.
-- For a binary modulus this is equivalent to the ones-complement of
- -- the original value. For non-binary modulus this is an arbitrary
+ -- the original value. For a nonbinary modulus this is an arbitrary
-- but consistent definition.
if Is_Modular_Integer_Type (Typ) then
-------------------------------
-- A qualified expression is potentially static if its subtype mark denotes
- -- a static subtype and its expression is potentially static (RM 4.9 (11)).
+ -- a static subtype and its expression is potentially static (RM 4.9 (10)).
procedure Eval_Qualified_Expression (N : Node_Id) is
Operand : constant Node_Id := Expression (N);
then
Check_Non_Static_Context (Operand);
- -- If operand is known to raise constraint_error, set the flag on the
+ -- If operand is known to raise Constraint_Error, set the flag on the
-- expression so it does not get optimized away.
if Nkind (Operand) = N_Raise_Constraint_Error then
end if;
return;
+
+ -- Also return if a semantic error has been posted on the node, as we
+ -- don't want to fold in that case (for GNATprove, the node might lead
+ -- to Constraint_Error but won't have been replaced with a raise node
+ -- or marked as raising CE).
+
+ elsif Error_Posted (N) then
+ return;
end if;
-- If not foldable we are done
if not Fold then
return;
- -- Don't try fold if target type has constraint error bounds
+ -- Don't try fold if target type has Constraint_Error bounds
elsif not Is_OK_Static_Subtype (Target_Type) then
Set_Raises_Constraint_Error (N);
return;
end if;
- -- Here we will fold, save Print_In_Hex indication
-
- Hex := Nkind (Operand) = N_Integer_Literal
- and then Print_In_Hex (Operand);
-
-- Fold the result of qualification
if Is_Discrete_Type (Target_Type) then
+
+ -- Save Print_In_Hex indication
+
+ Hex := Nkind (Operand) = N_Integer_Literal
+ and then Print_In_Hex (Operand);
+
Fold_Uint (N, Expr_Value (Operand), Stat);
-- Preserve Print_In_Hex indication
------------------------
-- Relational operations are static functions, so the result is static if
- -- 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.
+ -- both operands are static (RM 4.9(7), 4.9(20)), except that up to Ada
+ -- 2012, for strings the result is never static, even if the operands are.
+ -- The string case was relaxed in Ada 2020, see AI12-0201.
-- 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);
- Typ : constant Entity_Id := Etype (Left);
- Otype : Entity_Id := Empty;
- Result : Boolean;
+ Left : constant Node_Id := Left_Opnd (N);
+ Right : constant Node_Id := Right_Opnd (N);
- begin
- -- One special case to deal with first. If we can tell that the result
- -- will be false because the lengths of one or more index subtypes are
- -- compile time known and different, then we can replace the entire
- -- result by False. We only do this for one dimensional arrays, because
- -- the case of multi-dimensional arrays is rare and too much trouble. If
- -- one of the operands is an illegal aggregate, its type might still be
- -- an arbitrary composite type, so nothing to do.
+ procedure Decompose_Expr
+ (Expr : Node_Id;
+ Ent : out Entity_Id;
+ Kind : out Character;
+ Cons : out Uint;
+ Orig : Boolean := True);
+ -- Given expression Expr, see if it is of the form X [+/- K]. If so, Ent
+ -- is set to the entity in X, Kind is 'F','L','E' for 'First or 'Last or
+ -- simple entity, and Cons is the value of K. If the expression is not
+ -- of the required form, Ent is set to Empty.
+ --
+ -- Orig indicates whether Expr is the original expression to consider,
+ -- or if we are handling a subexpression (e.g. recursive call to
+ -- Decompose_Expr).
+
+ procedure Fold_General_Op (Is_Static : Boolean);
+ -- Attempt to fold arbitrary relational operator N. Flag Is_Static must
+ -- be set when the operator denotes a static expression.
+
+ procedure Fold_Static_Real_Op;
+ -- Attempt to fold static real type relational operator N
+
+ function Static_Length (Expr : Node_Id) return Uint;
+ -- If Expr is an expression for a constrained array whose length is
+ -- known at compile time, return the non-negative length, otherwise
+ -- return -1.
+
+ --------------------
+ -- Decompose_Expr --
+ --------------------
+
+ procedure Decompose_Expr
+ (Expr : Node_Id;
+ Ent : out Entity_Id;
+ Kind : out Character;
+ Cons : out Uint;
+ Orig : Boolean := True)
+ is
+ Exp : Node_Id;
- if Is_Array_Type (Typ)
- and then Typ /= Any_Composite
- and then Number_Dimensions (Typ) = 1
- and then (Nkind (N) = N_Op_Eq or else Nkind (N) = N_Op_Ne)
- then
- if Raises_Constraint_Error (Left)
- or else
- Raises_Constraint_Error (Right)
- then
- return;
- end if;
+ begin
+ -- Assume that the expression does not meet the expected form
- -- OK, we have the case where we may be able to do this fold
+ Cons := No_Uint;
+ Ent := Empty;
+ Kind := '?';
- Length_Mismatch : declare
- procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
- -- If Op is an expression for a constrained array with a known at
- -- compile time length, then Len is set to this (non-negative
- -- length). Otherwise Len is set to minus 1.
+ if Nkind (Expr) = N_Op_Add
+ and then Compile_Time_Known_Value (Right_Opnd (Expr))
+ then
+ Exp := Left_Opnd (Expr);
+ Cons := Expr_Value (Right_Opnd (Expr));
- -----------------------
- -- Get_Static_Length --
- -----------------------
+ elsif Nkind (Expr) = N_Op_Subtract
+ and then Compile_Time_Known_Value (Right_Opnd (Expr))
+ then
+ Exp := Left_Opnd (Expr);
+ Cons := -Expr_Value (Right_Opnd (Expr));
- procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
- T : Entity_Id;
+ -- If the bound is a constant created to remove side effects, recover
+ -- the original expression to see if it has one of the recognizable
+ -- forms.
- begin
- -- First easy case string literal
+ elsif Nkind (Expr) = N_Identifier
+ and then not Comes_From_Source (Entity (Expr))
+ and then Ekind (Entity (Expr)) = E_Constant
+ and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
+ then
+ Exp := Expression (Parent (Entity (Expr)));
+ Decompose_Expr (Exp, Ent, Kind, Cons, Orig => False);
+
+ -- If original expression includes an entity, create a reference
+ -- to it for use below.
+
+ if Present (Ent) then
+ Exp := New_Occurrence_Of (Ent, Sloc (Ent));
+ else
+ return;
+ end if;
+
+ else
+ -- Only consider the case of X + 0 for a full expression, and
+ -- not when recursing, otherwise we may end up with evaluating
+ -- expressions not known at compile time to 0.
+
+ if Orig then
+ Exp := Expr;
+ Cons := Uint_0;
+ else
+ return;
+ end if;
+ end if;
+
+ -- At this stage Exp is set to the potential X
+
+ if Nkind (Exp) = N_Attribute_Reference then
+ if Attribute_Name (Exp) = Name_First then
+ Kind := 'F';
+ elsif Attribute_Name (Exp) = Name_Last then
+ Kind := 'L';
+ else
+ return;
+ end if;
+
+ Exp := Prefix (Exp);
+
+ else
+ Kind := 'E';
+ end if;
+
+ if Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
+ Ent := Entity (Exp);
+ end if;
+ end Decompose_Expr;
+
+ ---------------------
+ -- Fold_General_Op --
+ ---------------------
+
+ procedure Fold_General_Op (Is_Static : Boolean) is
+ CR : constant Compare_Result :=
+ Compile_Time_Compare (Left, Right, Assume_Valid => False);
+
+ Result : Boolean;
+
+ begin
+ if CR = Unknown then
+ return;
+ end if;
- if Nkind (Op) = N_String_Literal then
- Len := UI_From_Int (String_Length (Strval (Op)));
+ case Nkind (N) is
+ when N_Op_Eq =>
+ if CR = EQ then
+ Result := True;
+ elsif CR = NE or else CR = GT or else CR = LT then
+ Result := False;
+ else
return;
end if;
- -- Second easy case, not constrained subtype, so no length
-
- if not Is_Constrained (Etype (Op)) then
- Len := Uint_Minus_1;
+ when N_Op_Ge =>
+ if CR = GT or else CR = EQ or else CR = GE then
+ Result := True;
+ elsif CR = LT then
+ Result := False;
+ else
return;
end if;
- -- General case
+ when N_Op_Gt =>
+ if CR = GT then
+ Result := True;
+ elsif CR = EQ or else CR = LT or else CR = LE then
+ Result := False;
+ else
+ return;
+ end if;
- T := Etype (First_Index (Etype (Op)));
+ when N_Op_Le =>
+ if CR = LT or else CR = EQ or else CR = LE then
+ Result := True;
+ elsif CR = GT then
+ Result := False;
+ else
+ return;
+ end if;
- -- The simple case, both bounds are known at compile time
+ when N_Op_Lt =>
+ if CR = LT then
+ Result := True;
+ elsif CR = EQ or else CR = GT or else CR = GE then
+ Result := False;
+ else
+ return;
+ end if;
- if Is_Discrete_Type (T)
- and then Compile_Time_Known_Value (Type_Low_Bound (T))
- and then Compile_Time_Known_Value (Type_High_Bound (T))
- then
- Len := UI_Max (Uint_0,
- Expr_Value (Type_High_Bound (T)) -
- Expr_Value (Type_Low_Bound (T)) + 1);
+ when N_Op_Ne =>
+ if CR = NE or else CR = GT or else CR = LT then
+ Result := True;
+ elsif CR = EQ then
+ Result := False;
+ else
return;
end if;
- -- A more complex case, where the bounds are of the form
- -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
- -- either A'First or A'Last (with A an entity name), or X is an
- -- entity name, and the two X's are the same and K1 and K2 are
- -- known at compile time, in this case, the length can also be
- -- computed at compile time, even though the bounds are not
- -- known. A common case of this is e.g. (X'First .. X'First+5).
-
- Extract_Length : declare
- procedure Decompose_Expr
- (Expr : Node_Id;
- Ent : out Entity_Id;
- Kind : out Character;
- Cons : out Uint);
- -- Given an expression see if it is of the form given above,
- -- X [+/- K]. If so Ent is set to the entity in X, Kind is
- -- 'F','L','E' for 'First/'Last/simple entity, and Cons is
- -- the value of K. If the expression is not of the required
- -- form, Ent is set to Empty.
-
- --------------------
- -- Decompose_Expr --
- --------------------
-
- procedure Decompose_Expr
- (Expr : Node_Id;
- Ent : out Entity_Id;
- Kind : out Character;
- Cons : out Uint)
- is
- Exp : Node_Id;
+ when others =>
+ raise Program_Error;
+ end case;
- begin
- if Nkind (Expr) = N_Op_Add
- and then Compile_Time_Known_Value (Right_Opnd (Expr))
- then
- Exp := Left_Opnd (Expr);
- Cons := Expr_Value (Right_Opnd (Expr));
+ -- Determine the potential outcome of the relation assuming the
+ -- operands are valid and emit a warning when the relation yields
+ -- True or False only in the presence of invalid values.
- elsif Nkind (Expr) = N_Op_Subtract
- and then Compile_Time_Known_Value (Right_Opnd (Expr))
- then
- Exp := Left_Opnd (Expr);
- Cons := -Expr_Value (Right_Opnd (Expr));
+ Warn_On_Constant_Valid_Condition (N);
- -- If the bound is a constant created to remove side
- -- effects, recover original expression to see if it has
- -- one of the recognizable forms.
+ Fold_Uint (N, Test (Result), Is_Static);
+ end Fold_General_Op;
- elsif Nkind (Expr) = N_Identifier
- and then not Comes_From_Source (Entity (Expr))
- and then Ekind (Entity (Expr)) = E_Constant
- and then
- Nkind (Parent (Entity (Expr))) = N_Object_Declaration
- then
- Exp := Expression (Parent (Entity (Expr)));
- Decompose_Expr (Exp, Ent, Kind, Cons);
+ -------------------------
+ -- Fold_Static_Real_Op --
+ -------------------------
- -- If original expression includes an entity, create a
- -- reference to it for use below.
+ procedure Fold_Static_Real_Op is
+ Left_Real : constant Ureal := Expr_Value_R (Left);
+ Right_Real : constant Ureal := Expr_Value_R (Right);
+ Result : Boolean;
- if Present (Ent) then
- Exp := New_Occurrence_Of (Ent, Sloc (Ent));
- end if;
+ begin
+ case Nkind (N) is
+ when N_Op_Eq => Result := (Left_Real = Right_Real);
+ when N_Op_Ge => Result := (Left_Real >= Right_Real);
+ when N_Op_Gt => Result := (Left_Real > Right_Real);
+ when N_Op_Le => Result := (Left_Real <= Right_Real);
+ when N_Op_Lt => Result := (Left_Real < Right_Real);
+ when N_Op_Ne => Result := (Left_Real /= Right_Real);
+ when others => raise Program_Error;
+ end case;
+
+ Fold_Uint (N, Test (Result), True);
+ end Fold_Static_Real_Op;
- else
- Exp := Expr;
- Cons := Uint_0;
- end if;
+ -------------------
+ -- Static_Length --
+ -------------------
+
+ function Static_Length (Expr : Node_Id) return Uint is
+ Cons1 : Uint;
+ Cons2 : Uint;
+ Ent1 : Entity_Id;
+ Ent2 : Entity_Id;
+ Kind1 : Character;
+ Kind2 : Character;
+ Typ : Entity_Id;
- -- At this stage Exp is set to the potential X
+ begin
+ -- First easy case string literal
- if Nkind (Exp) = N_Attribute_Reference then
- if Attribute_Name (Exp) = Name_First then
- Kind := 'F';
- elsif Attribute_Name (Exp) = Name_Last then
- Kind := 'L';
- else
- Ent := Empty;
- return;
- end if;
+ if Nkind (Expr) = N_String_Literal then
+ return UI_From_Int (String_Length (Strval (Expr)));
- Exp := Prefix (Exp);
+ -- With frontend inlining as performed in GNATprove mode, a variable
+ -- may be inserted that has a string literal subtype. Deal with this
+ -- specially as for the previous case.
- else
- Kind := 'E';
- end if;
+ elsif Ekind (Etype (Expr)) = E_String_Literal_Subtype then
+ return String_Literal_Length (Etype (Expr));
- if Is_Entity_Name (Exp) and then Present (Entity (Exp))
- then
- Ent := Entity (Exp);
- else
- Ent := Empty;
- end if;
- end Decompose_Expr;
+ -- Second easy case, not constrained subtype, so no length
- -- Local Variables
+ elsif not Is_Constrained (Etype (Expr)) then
+ return Uint_Minus_1;
+ end if;
- Ent1, Ent2 : Entity_Id;
- Kind1, Kind2 : Character;
- Cons1, Cons2 : Uint;
+ -- General case
- -- Start of processing for Extract_Length
+ Typ := Etype (First_Index (Etype (Expr)));
- begin
- Decompose_Expr
- (Original_Node (Type_Low_Bound (T)), Ent1, Kind1, Cons1);
- Decompose_Expr
- (Original_Node (Type_High_Bound (T)), Ent2, Kind2, Cons2);
-
- if Present (Ent1)
- and then Kind1 = Kind2
- and then Ent1 = Ent2
- then
- Len := Cons2 - Cons1 + 1;
- else
- Len := Uint_Minus_1;
- end if;
- end Extract_Length;
- end Get_Static_Length;
+ -- The simple case, both bounds are known at compile time
+
+ if Is_Discrete_Type (Typ)
+ and then Compile_Time_Known_Value (Type_Low_Bound (Typ))
+ and then Compile_Time_Known_Value (Type_High_Bound (Typ))
+ then
+ return
+ UI_Max (Uint_0, Expr_Value (Type_High_Bound (Typ)) -
+ Expr_Value (Type_Low_Bound (Typ)) + 1);
+ end if;
- -- Local Variables
+ -- A more complex case, where the bounds are of the form X [+/- K1]
+ -- .. X [+/- K2]), where X is an expression that is either A'First or
+ -- A'Last (with A an entity name), or X is an entity name, and the
+ -- two X's are the same and K1 and K2 are known at compile time, in
+ -- this case, the length can also be computed at compile time, even
+ -- though the bounds are not known. A common case of this is e.g.
+ -- (X'First .. X'First+5).
+
+ Decompose_Expr
+ (Original_Node (Type_Low_Bound (Typ)), Ent1, Kind1, Cons1);
+ Decompose_Expr
+ (Original_Node (Type_High_Bound (Typ)), Ent2, Kind2, Cons2);
+
+ if Present (Ent1) and then Ent1 = Ent2 and then Kind1 = Kind2 then
+ return Cons2 - Cons1 + 1;
+ else
+ return Uint_Minus_1;
+ end if;
+ end Static_Length;
- Len_L : Uint;
- Len_R : Uint;
+ -- Local variables
- -- Start of processing for Length_Mismatch
+ Left_Typ : constant Entity_Id := Etype (Left);
+ Right_Typ : constant Entity_Id := Etype (Right);
+ Fold : Boolean;
+ Left_Len : Uint;
+ Op_Typ : Entity_Id := Empty;
+ Right_Len : Uint;
- begin
- Get_Static_Length (Left, Len_L);
- Get_Static_Length (Right, Len_R);
+ Is_Static_Expression : Boolean;
+
+ -- Start of processing for Eval_Relational_Op
+
+ begin
+ -- One special case to deal with first. If we can tell that the result
+ -- will be false because the lengths of one or more index subtypes are
+ -- compile-time known and different, then we can replace the entire
+ -- result by False. We only do this for one-dimensional arrays, because
+ -- the case of multidimensional arrays is rare and too much trouble. If
+ -- one of the operands is an illegal aggregate, its type might still be
+ -- an arbitrary composite type, so nothing to do.
+
+ if Is_Array_Type (Left_Typ)
+ and then Left_Typ /= Any_Composite
+ and then Number_Dimensions (Left_Typ) = 1
+ and then Nkind (N) in N_Op_Eq | N_Op_Ne
+ then
+ if Raises_Constraint_Error (Left)
+ or else
+ Raises_Constraint_Error (Right)
+ then
+ return;
+
+ -- OK, we have the case where we may be able to do this fold
+
+ else
+ Left_Len := Static_Length (Left);
+ Right_Len := Static_Length (Right);
- if Len_L /= Uint_Minus_1
- and then Len_R /= Uint_Minus_1
- and then Len_L /= Len_R
+ if Left_Len /= Uint_Minus_1
+ and then Right_Len /= Uint_Minus_1
+ and then Left_Len /= Right_Len
then
- Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
+ -- AI12-0201: comparison of string is static in Ada 202x
+
+ Fold_Uint
+ (N,
+ Test (Nkind (N) = N_Op_Ne),
+ Static => Ada_Version >= Ada_2020
+ and then Is_String_Type (Left_Typ));
Warn_On_Known_Condition (N);
return;
end if;
- end Length_Mismatch;
- end if;
-
- declare
- Is_Static_Expression : Boolean;
+ end if;
- Is_Foldable : Boolean;
- pragma Unreferenced (Is_Foldable);
+ -- General case
- begin
- -- Initialize the value of Is_Static_Expression. The value of
- -- Is_Foldable returned by Test_Expression_Is_Foldable is not needed
- -- since, even when some operand is a variable, we can still perform
- -- the static evaluation of the expression in some cases (for
- -- example, for a variable of a subtype of Integer we statically
- -- know that any value stored in such variable is smaller than
- -- Integer'Last).
+ else
+ -- Initialize the value of Is_Static_Expression. The value of Fold
+ -- returned by Test_Expression_Is_Foldable is not needed since, even
+ -- when some operand is a variable, we can still perform the static
+ -- evaluation of the expression in some cases (for example, for a
+ -- variable of a subtype of Integer we statically know that any value
+ -- stored in such variable is smaller than Integer'Last).
Test_Expression_Is_Foldable
- (N, Left, Right, Is_Static_Expression, Is_Foldable);
-
- -- 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, except that
- -- as noted above, we allow equality/inequality for strings.
-
- 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;
+ (N, Left, Right, Is_Static_Expression, Fold);
+
+ -- Comparisons of scalars can give static results.
+ -- In addition starting with Ada 202x (AI12-0201), comparison of
+ -- strings can also give static results, and as noted above, we also
+ -- allow for earlier Ada versions internally generated equality and
+ -- inequality for strings.
+ -- ??? The Comes_From_Source test below isn't correct and will accept
+ -- some cases that are illegal in Ada 2012. and before. Now that
+ -- Ada 202x has relaxed the rules, this doesn't really matter.
+
+ if Is_String_Type (Left_Typ) then
+ if Ada_Version < Ada_2020
+ and then (Comes_From_Source (N)
+ or else Nkind (N) not in N_Op_Eq | N_Op_Ne)
+ then
+ Is_Static_Expression := False;
+ Set_Is_Static_Expression (N, False);
+ end if;
- elsif not Is_Scalar_Type (Typ) then
+ elsif not Is_Scalar_Type (Left_Typ) then
Is_Static_Expression := False;
Set_Is_Static_Expression (N, False);
end if;
-- an explicit scope, determine appropriate specific numeric type,
-- and diagnose possible ambiguity.
- if Is_Universal_Numeric_Type (Etype (Left))
+ if Is_Universal_Numeric_Type (Left_Typ)
and then
- Is_Universal_Numeric_Type (Etype (Right))
+ Is_Universal_Numeric_Type (Right_Typ)
then
- Otype := Find_Universal_Operator_Type (N);
+ Op_Typ := Find_Universal_Operator_Type (N);
end if;
- -- 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
- Left_Real : constant Ureal := Expr_Value_R (Left);
- Right_Real : constant Ureal := Expr_Value_R (Right);
-
- begin
- case Nkind (N) is
- when N_Op_Eq => Result := (Left_Real = Right_Real);
- when N_Op_Ne => Result := (Left_Real /= Right_Real);
- when N_Op_Lt => Result := (Left_Real < Right_Real);
- when N_Op_Le => Result := (Left_Real <= Right_Real);
- when N_Op_Gt => Result := (Left_Real > Right_Real);
- when N_Op_Ge => Result := (Left_Real >= Right_Real);
-
- when others =>
- raise Program_Error;
- end case;
-
- Fold_Uint (N, Test (Result), True);
- end;
-
- -- For all other cases, we use Compile_Time_Compare to do the compare
+ -- Attempt to fold the relational operator
+ if Is_Static_Expression and then Is_Real_Type (Left_Typ) then
+ Fold_Static_Real_Op;
else
- declare
- CR : constant Compare_Result :=
- Compile_Time_Compare
- (Left, Right, Assume_Valid => False);
-
- begin
- if CR = Unknown then
- return;
- end if;
-
- case Nkind (N) is
- when N_Op_Eq =>
- if CR = EQ then
- Result := True;
- elsif CR = NE or else CR = GT or else CR = LT then
- Result := False;
- else
- return;
- end if;
-
- when N_Op_Ne =>
- if CR = NE or else CR = GT or else CR = LT then
- Result := True;
- elsif CR = EQ then
- Result := False;
- else
- return;
- end if;
-
- when N_Op_Lt =>
- if CR = LT then
- Result := True;
- elsif CR = EQ or else CR = GT or else CR = GE then
- Result := False;
- else
- return;
- end if;
-
- when N_Op_Le =>
- if CR = LT or else CR = EQ or else CR = LE then
- Result := True;
- elsif CR = GT then
- Result := False;
- else
- return;
- end if;
-
- when N_Op_Gt =>
- if CR = GT then
- Result := True;
- elsif CR = EQ or else CR = LT or else CR = LE then
- Result := False;
- else
- return;
- end if;
-
- when N_Op_Ge =>
- if CR = GT or else CR = EQ or else CR = GE then
- Result := True;
- elsif CR = LT then
- Result := False;
- else
- return;
- end if;
-
- when others =>
- raise Program_Error;
- end case;
- end;
-
- Fold_Uint (N, Test (Result), Is_Static_Expression);
+ Fold_General_Op (Is_Static_Expression);
end if;
- end;
+ end if;
-- For the case of a folded relational operator on a specific numeric
- -- type, freeze operand type now.
+ -- type, freeze the operand type now.
- if Present (Otype) then
- Freeze_Before (N, Otype);
+ if Present (Op_Typ) then
+ Freeze_Before (N, Op_Typ);
end if;
Warn_On_Known_Condition (N);
-- Eval_Shift --
----------------
- -- Shift operations are intrinsic operations that can never be static, so
- -- the only processing required is to perform the required check for a non
- -- static context for the two operands.
-
- -- Actually we could do some compile time evaluation here some time ???
-
procedure Eval_Shift (N : Node_Id) is
begin
- Check_Non_Static_Context (Left_Opnd (N));
- Check_Non_Static_Context (Right_Opnd (N));
+ -- This procedure is only called for compiler generated code (e.g.
+ -- packed arrays), so there is nothing to do except attempting to fold
+ -- the expression.
+
+ Fold_Shift (N, Left_Opnd (N), Right_Opnd (N), Nkind (N));
end Eval_Shift;
------------------------
-- Now look at the operands, we can't quite use the normal call to
-- Test_Expression_Is_Foldable here because short circuit operations
-- are a special case, they can still be foldable, even if the right
- -- operand raises constraint error.
+ -- operand raises Constraint_Error.
-- If either operand is Any_Type, just propagate to result and do not
-- try to fold, this prevents cascaded errors.
Set_Etype (N, Any_Type);
return;
- -- If left operand raises constraint error, then replace node N with
- -- the raise constraint error node, and we are obviously not foldable.
+ -- If left operand raises Constraint_Error, then replace node N with
+ -- the raise Constraint_Error node, and we are obviously not foldable.
-- Is_Static_Expression is set from the two operands in the normal way,
-- and we check the right operand if it is in a non-static context.
-- Here the result is static, note that, unlike the normal processing
-- in Test_Expression_Is_Foldable, we did *not* check above to see if
- -- the right operand raises constraint error, that's because it is not
+ -- the right operand raises Constraint_Error, that's because it is not
-- significant if the left operand is decisive.
Set_Is_Static_Expression (N);
- -- It does not matter if the right operand raises constraint error if
+ -- It does not matter if the right operand raises Constraint_Error if
-- it will not be evaluated. So deal specially with the cases where
-- the right operand is not evaluated. Note that we will fold these
-- cases even if the right operand is non-static, which is fine, but
end if;
-- If first operand not decisive, then it does matter if the right
- -- operand raises constraint error, since it will be evaluated, so
+ -- operand raises Constraint_Error, since it will be evaluated, so
-- we simply replace the node with the right operand. Note that this
-- properly propagates Is_Static_Expression and Raises_Constraint_Error
-- (both are set to True in Right).
end if;
-- If original node was a type conversion, then result if non-static
+ -- up to Ada 2012. AI12-0201 changes that with Ada 202x.
- if Nkind (Original_Node (N)) = N_Type_Conversion then
+ if Nkind (Original_Node (N)) = N_Type_Conversion
+ and then Ada_Version <= Ada_2012
+ then
Set_Is_Static_Expression (N, False);
return;
end if;
-- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
-- if its bounds are outside the index base type and this index type is
-- static. This can happen in only two ways. Either the string literal
- -- is too long, or it is null, and the lower bound is type'First. In
- -- either case it is the upper bound that is out of range of the index
- -- type.
+ -- is too long, or it is null, and the lower bound is type'First. Either
+ -- way it is the upper bound that is out of range of the index type.
+
if Ada_Version >= Ada_95 then
- if Root_Type (Bas) = Standard_String
- or else
- Root_Type (Bas) = Standard_Wide_String
- or else
- Root_Type (Bas) = Standard_Wide_Wide_String
- then
+ if Is_Standard_String_Type (Bas) then
Xtp := Standard_Positive;
else
Xtp := Etype (First_Index (Bas));
-- A type conversion is potentially static if its subtype mark is for a
-- static scalar subtype, and its operand expression is potentially static
-- (RM 4.9(10)).
+ -- Also add support for static string types.
procedure Eval_Type_Conversion (N : Node_Id) is
Operand : constant Node_Id := Expression (N);
Source_Type : constant Entity_Id := Etype (Operand);
Target_Type : constant Entity_Id := Etype (N);
- Stat : Boolean;
- Fold : Boolean;
-
function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
-- Returns true if type T is an integer type, or if it is a fixed-point
-- type to be treated as an integer (i.e. the flag Conversion_OK is set
or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
end To_Be_Treated_As_Real;
+ -- Local variables
+
+ Fold : Boolean;
+ Stat : Boolean;
+
-- Start of processing for Eval_Type_Conversion
begin
if not Fold then
return;
- -- Don't try fold if target type has constraint error bounds
+ -- Don't try fold if target type has Constraint_Error bounds
elsif not Is_OK_Static_Subtype (Target_Type) then
Set_Raises_Constraint_Error (N);
-- following type test, fixed-point counts as real unless the flag
-- Conversion_OK is set, in which case it counts as integer.
- -- Fold conversion, case of string type. The result is not static
+ -- Fold conversion, case of string type. The result is static starting
+ -- with Ada 202x (AI12-0201).
if Is_String_Type (Target_Type) then
- Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
+ Fold_Str
+ (N,
+ Strval (Get_String_Val (Operand)),
+ Static => Ada_Version >= Ada_2020);
return;
-- Fold conversion, case of integer target type
-- Real to integer conversion
- else
+ elsif To_Be_Treated_As_Real (Source_Type) then
Result := UR_To_Uint (Expr_Value_R (Operand));
+
+ -- Enumeration to integer conversion, aka 'Enum_Rep
+
+ else
+ Result := Expr_Rep_Value (Operand);
end if;
-- If fixed-point type (Conversion_OK must be set), then the
if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
Out_Of_Range (N);
end if;
-
end Eval_Type_Conversion;
-------------------
pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
return Corresponding_Integer_Value (N);
- -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
+ -- The NULL access value
- elsif Kind = N_Attribute_Reference
- and then Attribute_Name (N) = Name_Null_Parameter
- then
+ elsif Kind = N_Null then
+ pragma Assert (Is_Access_Type (Underlying_Type (Etype (N)))
+ or else Error_Posted (N));
return Uint_0;
- -- Otherwise must be character literal
+ -- Character literal
- else
- pragma Assert (Kind = N_Character_Literal);
+ elsif Kind = N_Character_Literal then
Ent := Entity (N);
-- Since Character literals of type Standard.Character don't have any
else
return Enumeration_Rep (Ent);
end if;
+
+ -- Unchecked conversion, which can come from System'To_Address (X)
+ -- where X is a static integer expression. Recursively evaluate X.
+
+ elsif Kind = N_Unchecked_Type_Conversion then
+ return Expr_Rep_Value (Expression (N));
+
+ else
+ raise Program_Error;
end if;
end Expr_Rep_Value;
Val : Uint;
begin
- -- If already in cache, then we know it's compile time known and we can
+ -- If already in cache, then we know it's compile-time-known and we can
-- return the value that was previously stored in the cache since
- -- compile time known values cannot change.
+ -- compile-time-known values cannot change.
if CV_Ent.N = N then
return CV_Ent.V;
pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
Val := Corresponding_Integer_Value (N);
- -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
+ -- The NULL access value
- elsif Kind = N_Attribute_Reference
- and then Attribute_Name (N) = Name_Null_Parameter
- then
+ elsif Kind = N_Null then
+ pragma Assert (Is_Access_Type (Underlying_Type (Etype (N)))
+ or else Error_Posted (N));
Val := Uint_0;
- -- Otherwise must be character literal
+ -- Character literal
- else
- pragma Assert (Kind = N_Character_Literal);
+ elsif Kind = N_Character_Literal then
Ent := Entity (N);
-- Since Character literals of type Standard.Character don't
else
Val := Enumeration_Pos (Ent);
end if;
+
+ -- Unchecked conversion, which can come from System'To_Address (X)
+ -- where X is a static integer expression. Recursively evaluate X.
+
+ elsif Kind = N_Unchecked_Type_Conversion then
+ Val := Expr_Value (Expression (N));
+
+ else
+ raise Program_Error;
end if;
-- Come here with Val set to value to be returned, set cache
return Ent;
else
pragma Assert (Ekind (Ent) = E_Constant);
- return Expr_Value_E (Constant_Value (Ent));
+
+ -- We may be dealing with a enumerated character type constant, so
+ -- handle that case here.
+
+ if Nkind (Constant_Value (Ent)) = N_Character_Literal then
+ return Ent;
+ else
+ return Expr_Value_E (Constant_Value (Ent));
+ end if;
end if;
end Expr_Value_E;
elsif Kind = N_Integer_Literal then
return UR_From_Uint (Expr_Value (N));
- -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
+ -- Here, we have a node that cannot be interpreted as a compile time
+ -- constant. That is definitely an error.
- elsif Kind = N_Attribute_Reference
- and then Attribute_Name (N) = Name_Null_Parameter
- then
- return Ureal_0;
+ else
+ raise Program_Error;
end if;
-
- -- If we fall through, we have a node that cannot be interpreted as a
- -- compile time constant. That is definitely an error.
-
- raise Program_Error;
end Expr_Value_R;
------------------
end if;
end Flag_Non_Static_Expr;
+ ----------------
+ -- Fold_Dummy --
+ ----------------
+
+ procedure Fold_Dummy (N : Node_Id; Typ : Entity_Id) is
+ begin
+ if Is_Integer_Type (Typ) then
+ Fold_Uint (N, Uint_1, Static => True);
+
+ elsif Is_Real_Type (Typ) then
+ Fold_Ureal (N, Ureal_1, Static => True);
+
+ elsif Is_Enumeration_Type (Typ) then
+ Fold_Uint
+ (N,
+ Expr_Value (Type_Low_Bound (Base_Type (Typ))),
+ Static => True);
+
+ elsif Is_String_Type (Typ) then
+ Fold_Str
+ (N,
+ Strval (Make_String_Literal (Sloc (N), "")),
+ Static => True);
+ end if;
+ end Fold_Dummy;
+
+ ----------------
+ -- Fold_Shift --
+ ----------------
+
+ procedure Fold_Shift
+ (N : Node_Id;
+ Left : Node_Id;
+ Right : Node_Id;
+ Op : Node_Kind;
+ Static : Boolean := False;
+ Check_Elab : Boolean := False)
+ is
+ Typ : constant Entity_Id := Etype (Left);
+
+ procedure Check_Elab_Call;
+ -- Add checks related to calls in elaboration code
+
+ ---------------------
+ -- Check_Elab_Call --
+ ---------------------
+
+ procedure Check_Elab_Call is
+ begin
+ if Check_Elab then
+ if Legacy_Elaboration_Checks then
+ Check_Elab_Call (N);
+ end if;
+
+ Build_Call_Marker (N);
+ end if;
+ end Check_Elab_Call;
+
+ begin
+ if Compile_Time_Known_Value (Left)
+ and then Compile_Time_Known_Value (Right)
+ then
+ pragma Assert (not Non_Binary_Modulus (Typ));
+
+ if Op = N_Op_Shift_Left then
+ Check_Elab_Call;
+
+ -- Fold Shift_Left (X, Y) by computing (X * 2**Y) rem modulus
+
+ Fold_Uint
+ (N,
+ (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right)))
+ rem Modulus (Typ),
+ Static => Static);
+
+ elsif Op = N_Op_Shift_Right then
+ Check_Elab_Call;
+
+ -- Fold Shift_Right (X, Y) by computing abs X / 2**Y
+
+ Fold_Uint
+ (N,
+ abs Expr_Value (Left) / (Uint_2 ** Expr_Value (Right)),
+ Static => Static);
+
+ elsif Op = N_Op_Shift_Right_Arithmetic then
+ Check_Elab_Call;
+
+ declare
+ Two_Y : constant Uint := Uint_2 ** Expr_Value (Right);
+ Modulus : Uint;
+ begin
+ if Is_Modular_Integer_Type (Typ) then
+ Modulus := Einfo.Modulus (Typ);
+ else
+ Modulus := Uint_2 ** RM_Size (Typ);
+ end if;
+
+ -- X / 2**Y if X if positive or a small enough modular integer
+
+ if (Is_Modular_Integer_Type (Typ)
+ and then Expr_Value (Left) < Modulus / Uint_2)
+ or else
+ (not Is_Modular_Integer_Type (Typ)
+ and then Expr_Value (Left) >= 0)
+ then
+ Fold_Uint (N, Expr_Value (Left) / Two_Y, Static => Static);
+
+ -- -1 (aka all 1's) if Y is larger than the number of bits
+ -- available or if X = -1.
+
+ elsif Two_Y > Modulus
+ or else Expr_Value (Left) = Uint_Minus_1
+ then
+ if Is_Modular_Integer_Type (Typ) then
+ Fold_Uint (N, Modulus - Uint_1, Static => Static);
+ else
+ Fold_Uint (N, Uint_Minus_1, Static => Static);
+ end if;
+
+ -- Large modular integer, compute via multiply/divide the
+ -- following: X >> Y + (1 << Y - 1) << (RM_Size - Y)
+
+ elsif Is_Modular_Integer_Type (Typ) then
+ Fold_Uint
+ (N,
+ (Expr_Value (Left)) / Two_Y
+ + (Two_Y - Uint_1)
+ * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right)),
+ Static => Static);
+
+ -- Negative signed integer, compute via multiple/divide the
+ -- following:
+ -- (Modulus + X) >> Y + (1 << Y - 1) << (RM_Size - Y) - Modulus
+
+ else
+ Fold_Uint
+ (N,
+ (Modulus + Expr_Value (Left)) / Two_Y
+ + (Two_Y - Uint_1)
+ * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right))
+ - Modulus,
+ Static => Static);
+ end if;
+ end;
+ end if;
+ end if;
+ end Fold_Shift;
+
--------------
-- Fold_Str --
--------------
return;
end if;
- -- If we are folding a named number, retain the entity in the literal,
- -- for ASIS use.
+ -- If we are folding a named number, retain the entity in the literal
+ -- in the original tree.
if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer then
Ent := Entity (N);
-- For a result of type integer, substitute an N_Integer_Literal node
-- for the result of the compile time evaluation of the expression.
- -- For ASIS use, set a link to the original named number when not in
- -- a generic context.
+ -- Set a link to the original named number when not in a generic context
+ -- for reference in the original tree.
if Is_Integer_Type (Typ) then
Rewrite (N, Make_Integer_Literal (Loc, Val));
return;
end if;
- -- If we are folding a named number, retain the entity in the literal,
- -- for ASIS use.
+ -- If we are folding a named number, retain the entity in the literal
+ -- in the original tree.
if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real then
Ent := Entity (N);
Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
- -- Set link to original named number, for ASIS use
+ -- Set link to original named number
Set_Original_Entity (N, Ent);
-- will cause semantic errors if it is marked as static), and after
-- the Resolve step (since Resolve in some cases sets this flag).
+ -- We mark the node as analyzed so that its type is not erased by
+ -- calling Analyze_Real_Literal.
+
Analyze (N);
Set_Is_Static_Expression (N, Static);
Set_Etype (N, Typ);
Resolve (N);
+ Set_Analyzed (N);
Set_Is_Static_Expression (N, Static);
end Fold_Ureal;
function Get_String_Val (N : Node_Id) return Node_Id is
begin
- if Nkind_In (N, N_String_Literal, N_Character_Literal) then
+ if Nkind (N) in N_String_Literal | N_Character_Literal then
return N;
else
pragma Assert (Is_Entity_Name (N));
end if;
-- If bounds not comparable at compile time, then the bounds of T2
- -- must be compile time known or we cannot answer the query.
+ -- must be compile-time-known or we cannot answer the query.
if not Compile_Time_Known_Value (L2)
or else not Compile_Time_Known_Value (H2)
exception
when others =>
-
- -- Debug flag K disables this behavior (useful for debugging)
+ -- With debug flag K we will get an exception unless an error has
+ -- already occurred (useful for debugging).
if Debug_Flag_K then
- raise;
- else
- return False;
+ Check_Error_Detected;
end if;
+
+ return False;
end In_Subrange_Of;
-----------------
-------------------
function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
- Typ : constant Entity_Id := Etype (Lo);
-
begin
- if not Compile_Time_Known_Value (Lo)
- or else not Compile_Time_Known_Value (Hi)
+ if Compile_Time_Known_Value (Lo)
+ and then Compile_Time_Known_Value (Hi)
then
- return False;
- end if;
+ declare
+ Typ : Entity_Id := Etype (Lo);
+ begin
+ -- When called from the frontend, as part of the analysis of
+ -- potentially static expressions, Typ will be the full view of a
+ -- type with all the info needed to answer this query. When called
+ -- from the backend, for example to know whether a range of a loop
+ -- is null, Typ might be a private type and we need to explicitly
+ -- switch to its corresponding full view to access the same info.
+
+ if Is_Incomplete_Or_Private_Type (Typ)
+ and then Present (Full_View (Typ))
+ then
+ Typ := Full_View (Typ);
+ end if;
- if Is_Discrete_Type (Typ) then
- return Expr_Value (Lo) > Expr_Value (Hi);
- else pragma Assert (Is_Real_Type (Typ));
- return Expr_Value_R (Lo) > Expr_Value_R (Hi);
+ if Is_Discrete_Type (Typ) then
+ return Expr_Value (Lo) > Expr_Value (Hi);
+ else pragma Assert (Is_Real_Type (Typ));
+ return Expr_Value_R (Lo) > Expr_Value_R (Hi);
+ end if;
+ end;
+ else
+ return False;
end if;
end Is_Null_Range;
return Is_OK_Static_Range (Choice);
elsif Nkind (Choice) = N_Subtype_Indication
- or else
- (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
+ or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
return Is_OK_Static_Subtype (Etype (Choice));
--------------------------
-- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
- -- neither bound raises constraint error when evaluated.
+ -- neither bound raises Constraint_Error when evaluated.
function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
Base_T : constant Entity_Id := Base_Type (Typ);
then
return False;
+ elsif Has_Dynamic_Predicate_Aspect (Typ) then
+ return False;
+
-- String types
elsif Is_String_Type (Typ) then
return Is_Static_Range (Choice);
elsif Nkind (Choice) = N_Subtype_Indication
- or else
- (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
+ or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
return Is_Static_Subtype (Etype (Choice));
return True;
end Is_Static_Choice_List;
----------------------
+ ---------------------
-- Is_Static_Range --
---------------------
then
return False;
+ -- If there is a dynamic predicate for the type (declared or inherited)
+ -- the expression is not static.
+
+ elsif Has_Dynamic_Predicate_Aspect (Typ)
+ or else (Is_Derived_Type (Typ)
+ and then Has_Aspect (Typ, Aspect_Dynamic_Predicate))
+ then
+ return False;
+
-- String types
elsif Is_String_Type (Typ) then
--------------------
function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
- Typ : constant Entity_Id := Etype (Lo);
-
begin
- if not Compile_Time_Known_Value (Lo)
- or else not Compile_Time_Known_Value (Hi)
+ if Compile_Time_Known_Value (Lo)
+ and then Compile_Time_Known_Value (Hi)
then
+ declare
+ Typ : Entity_Id := Etype (Lo);
+ begin
+ -- When called from the frontend, as part of the analysis of
+ -- potentially static expressions, Typ will be the full view of a
+ -- type with all the info needed to answer this query. When called
+ -- from the backend, for example to know whether a range of a loop
+ -- is null, Typ might be a private type and we need to explicitly
+ -- switch to its corresponding full view to access the same info.
+
+ if Is_Incomplete_Or_Private_Type (Typ)
+ and then Present (Full_View (Typ))
+ then
+ Typ := Full_View (Typ);
+ end if;
+
+ if Is_Discrete_Type (Typ) then
+ return Expr_Value (Lo) <= Expr_Value (Hi);
+ else pragma Assert (Is_Real_Type (Typ));
+ return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
+ end if;
+ end;
+ else
return False;
end if;
- if Is_Discrete_Type (Typ) then
- return Expr_Value (Lo) <= Expr_Value (Hi);
- else pragma Assert (Is_Real_Type (Typ));
- return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
- end if;
end Not_Null_Range;
-------------
First_Rep_Item (Parent (N)));
Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
- -- All cases except the special array case
+ -- All cases except the special array case.
+ -- No message if we are dealing with System.Priority values in
+ -- CodePeer mode where the target runtime may have more priorities.
- else
- Apply_Compile_Time_Constraint_Error
- (N, "value not in range of}", CE_Range_Check_Failed);
+ elsif not CodePeer_Mode or else Etype (N) /= RTE (RE_Priority) then
+ -- 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
+ Apply_Compile_Time_Constraint_Error
+ (N, "value not in range of}??", CE_Range_Check_Failed);
+ else
+ Apply_Compile_Time_Constraint_Error
+ (N, "value not in range of}", CE_Range_Check_Failed);
+ end if;
end if;
-- Here we generate a warning for the Ada 83 case, or when we are in an
end if;
end Out_Of_Range;
+ ---------------------------
+ -- Predicates_Compatible --
+ ---------------------------
+
+ function Predicates_Compatible (T1, T2 : Entity_Id) return Boolean is
+
+ function T2_Rep_Item_Applies_To_T1 (Nam : Name_Id) return Boolean;
+ -- Return True if the rep item for Nam is either absent on T2 or also
+ -- applies to T1.
+
+ -------------------------------
+ -- T2_Rep_Item_Applies_To_T1 --
+ -------------------------------
+
+ function T2_Rep_Item_Applies_To_T1 (Nam : Name_Id) return Boolean is
+ Rep_Item : constant Node_Id := Get_Rep_Item (T2, Nam);
+
+ begin
+ return No (Rep_Item) or else Get_Rep_Item (T1, Nam) = Rep_Item;
+ end T2_Rep_Item_Applies_To_T1;
+
+ -- Start of processing for Predicates_Compatible
+
+ begin
+ if Ada_Version < Ada_2012 then
+ return True;
+
+ -- If T2 has no predicates, there is no compatibility issue
+
+ elsif not Has_Predicates (T2) then
+ return True;
+
+ -- T2 has predicates, if T1 has none then we defer to the static check
+
+ elsif not Has_Predicates (T1) then
+ null;
+
+ -- Both T2 and T1 have predicates, check that all predicates that apply
+ -- to T2 apply also to T1 (RM 4.9.1(9/3)).
+
+ elsif T2_Rep_Item_Applies_To_T1 (Name_Static_Predicate)
+ and then T2_Rep_Item_Applies_To_T1 (Name_Dynamic_Predicate)
+ and then T2_Rep_Item_Applies_To_T1 (Name_Predicate)
+ then
+ return True;
+ end if;
+
+ -- Implement the static check prescribed by RM 4.9.1(10/3)
+
+ if Is_Static_Subtype (T1) and then Is_Static_Subtype (T2) then
+ -- We just need to query Interval_Lists for discrete types
+
+ if Is_Discrete_Type (T1) and then Is_Discrete_Type (T2) then
+ declare
+ Interval_List1 : constant Interval_Lists.Discrete_Interval_List
+ := Interval_Lists.Type_Intervals (T1);
+ Interval_List2 : constant Interval_Lists.Discrete_Interval_List
+ := Interval_Lists.Type_Intervals (T2);
+ begin
+ return Interval_Lists.Is_Subset (Interval_List1, Interval_List2)
+ and then not (Has_Predicates (T1)
+ and then not Predicate_Checks_Suppressed (T2)
+ and then Predicate_Checks_Suppressed (T1));
+ end;
+
+ else
+ -- TBD: Implement Interval_Lists for real types
+
+ return False;
+ end if;
+
+ -- If either subtype is not static, the predicates are not compatible
+
+ else
+ return False;
+ end if;
+ end Predicates_Compatible;
+
----------------------
-- Predicates_Match --
----------------------
function Predicates_Match (T1, T2 : Entity_Id) return Boolean is
- Pred1 : Node_Id;
- Pred2 : Node_Id;
+
+ function Have_Same_Rep_Item (Nam : Name_Id) return Boolean;
+ -- Return True if T1 and T2 have the same rep item for Nam
+
+ ------------------------
+ -- Have_Same_Rep_Item --
+ ------------------------
+
+ function Have_Same_Rep_Item (Nam : Name_Id) return Boolean is
+ begin
+ return Get_Rep_Item (T1, Nam) = Get_Rep_Item (T2, Nam);
+ end Have_Same_Rep_Item;
+
+ -- Start of processing for Predicates_Match
begin
if Ada_Version < Ada_2012 then
return True;
- -- Both types must have predicates or lack them
+ -- If T2 has no predicates, match if and only if T1 has none
+
+ elsif not Has_Predicates (T2) then
+ return not Has_Predicates (T1);
- elsif Has_Predicates (T1) /= Has_Predicates (T2) then
+ -- T2 has predicates, no match if T1 has none
+
+ elsif not Has_Predicates (T1) then
return False;
- -- Check matching predicates
+ -- Both T2 and T1 have predicates, check that they all come
+ -- from the same declarations.
else
- Pred1 :=
- Get_Rep_Item
- (T1, Name_Static_Predicate, Check_Parents => False);
- Pred2 :=
- Get_Rep_Item
- (T2, Name_Static_Predicate, Check_Parents => False);
-
- -- Subtypes statically match if the predicate comes from the
- -- same declaration, which can only happen if one is a subtype
- -- of the other and has no explicit predicate.
-
- -- Suppress warnings on order of actuals, which is otherwise
- -- triggered by one of the two calls below.
-
- pragma Warnings (Off);
- return Pred1 = Pred2
- or else (No (Pred1) and then Is_Subtype_Of (T1, T2))
- or else (No (Pred2) and then Is_Subtype_Of (T2, T1));
- pragma Warnings (On);
+ return Have_Same_Rep_Item (Name_Static_Predicate)
+ and then Have_Same_Rep_Item (Name_Dynamic_Predicate)
+ and then Have_Same_Rep_Item (Name_Predicate);
end if;
end Predicates_Match;
return Skip;
end;
+ -- The predicate function may contain string-comparison operations
+ -- that have been converted into calls to run-time array-comparison
+ -- routines. To evaluate the predicate statically, we recover the
+ -- original comparison operation and replace the occurrence of the
+ -- formal by the static string value. The actuals of the generated
+ -- call are of the form X'Address.
+
+ elsif Nkind (N) in N_Op_Compare
+ and then Nkind (Left_Opnd (N)) = N_Function_Call
+ then
+ declare
+ C : constant Node_Id := Left_Opnd (N);
+ F : constant Node_Id := First (Parameter_Associations (C));
+ L : constant Node_Id := Prefix (F);
+ R : constant Node_Id := Prefix (Next (F));
+
+ begin
+ -- If an operand is an entity name, it is the formal of the
+ -- predicate function, so replace it with the string value.
+ -- It may be either operand in the call. The other operand
+ -- is a static string from the original predicate.
+
+ if Is_Entity_Name (L) then
+ Rewrite (Left_Opnd (N), New_Copy (Val));
+ Rewrite (Right_Opnd (N), New_Copy (R));
+
+ else
+ Rewrite (Left_Opnd (N), New_Copy (L));
+ Rewrite (Right_Opnd (N), New_Copy (Val));
+ end if;
+
+ return Skip;
+ end;
+
else
return OK;
end if;
-- First deal with special case of inherited predicate, where the
-- predicate expression looks like:
- -- Expr and then xxPredicate (typ (Ent))
+ -- xxPredicate (typ (Ent)) and then Expr
-- where Expr is the predicate expression for this level, and the
- -- right operand is the call to evaluate the inherited predicate.
+ -- left operand is the call to evaluate the inherited predicate.
if Nkind (Expr) = N_And_Then
- and then Nkind (Right_Opnd (Expr)) = N_Function_Call
+ and then Nkind (Left_Opnd (Expr)) = N_Function_Call
+ and then Is_Predicate_Function (Entity (Name (Left_Opnd (Expr))))
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))))))
+ Typ => Etype (First_Formal (Entity (Name (Left_Opnd (Expr))))))
then
return False;
end if;
- -- Use the left operand for the continued processing
+ -- Use the right operand for the continued processing
- Copy := Copy_Separate_Tree (Left_Opnd (Expr));
+ Copy := Copy_Separate_Tree (Right_Opnd (Expr));
- -- Case where call to predicate function appears on its own
+ -- Case where call to predicate function appears on its own (this means
+ -- that the predicate at this level is just inherited from the parent).
- elsif Nkind (Expr) = N_Function_Call then
+ elsif Nkind (Expr) = N_Function_Call then
+ declare
+ Typ : constant Entity_Id :=
+ Etype (First_Formal (Entity (Name (Expr))));
- -- Here the result is just the result of calling the inner predicate
+ begin
+ -- If the inherited predicate is dynamic, just ignore it. We can't
+ -- go trying to evaluate a dynamic predicate as a static one!
- return
- Real_Or_String_Static_Predicate_Matches
- (Val => Val,
- Typ => Etype (First_Formal (Entity (Name (Expr)))));
+ if Has_Dynamic_Predicate_Aspect (Typ) then
+ return True;
+
+ -- Otherwise inherited predicate is static, check for match
+
+ else
+ return Real_Or_String_Static_Predicate_Matches (Val, Typ);
+ end if;
+ end;
- -- If no inherited predicate, copy whole expression
+ -- If not just an inherited predicate, copy whole expression
else
Copy := Copy_Separate_Tree (Expr);
-------------------------
procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
- Typ : constant Entity_Id := Etype (N);
Stat : constant Boolean := Is_Static_Expression (N);
+ Typ : constant Entity_Id := Etype (N);
begin
-- If we want to raise CE in the condition of a N_Raise_CE node, we
then
Set_Condition (Parent (N), Empty);
- -- If the expression raising CE is a N_Raise_CE node, we can use that
- -- one. We just preserve the type of the context.
-
- elsif Nkind (Exp) = N_Raise_Constraint_Error then
- Rewrite (N, Exp);
- Set_Etype (N, Typ);
-
-- Else build an explicit N_Raise_CE
else
- Rewrite (N,
- Make_Raise_Constraint_Error (Sloc (Exp),
- Reason => CE_Range_Check_Failed));
+ if Nkind (Exp) = N_Raise_Constraint_Error then
+ Rewrite (N,
+ Make_Raise_Constraint_Error (Sloc (Exp),
+ Reason => Reason (Exp)));
+ else
+ Rewrite (N,
+ Make_Raise_Constraint_Error (Sloc (Exp),
+ Reason => CE_Range_Check_Failed));
+ end if;
+
Set_Raises_Constraint_Error (N);
Set_Etype (N, Typ);
end if;
Set_Is_Static_Expression (N, Stat);
end Rewrite_In_Raise_CE;
+ ------------------------------------------------
+ -- Set_Checking_Potentially_Static_Expression --
+ ------------------------------------------------
+
+ procedure Set_Checking_Potentially_Static_Expression (Value : Boolean) is
+ begin
+ -- Verify that we're not currently checking for a potentially static
+ -- expression unless we're disabling such checking.
+
+ pragma Assert
+ (not Checking_For_Potentially_Static_Expression or else not Value);
+
+ Checking_For_Potentially_Static_Expression := Value;
+ end Set_Checking_Potentially_Static_Expression;
+
---------------------
-- String_Type_Len --
---------------------
Formal_Derived_Matching : Boolean := False) return Boolean
is
begin
+ -- A type is always statically compatible with itself
+
+ if T1 = T2 then
+ return True;
+
+ -- Not compatible if predicates are not compatible
+
+ elsif not Predicates_Compatible (T1, T2) then
+ return False;
+
-- Scalar types
- if Is_Scalar_Type (T1) then
+ elsif Is_Scalar_Type (T1) then
-- Definitely compatible if we match
then
return False;
- -- If either type has constraint error bounds, then consider that
- -- they match to avoid junk cascaded errors here.
-
- elsif not Is_OK_Static_Subtype (T1)
- or else not Is_OK_Static_Subtype (T2)
- then
- return True;
-
-- Base types must match, but we don't check that (should we???) but
-- we do at least check that both types are real, or both types are
-- not real.
begin
if Is_Real_Type (T1) then
return
- (Expr_Value_R (LB1) > Expr_Value_R (HB1))
+ Expr_Value_R (LB1) > Expr_Value_R (HB1)
or else
- (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
- and then
- Expr_Value_R (HB1) <= Expr_Value_R (HB2));
+ (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
+ and then Expr_Value_R (HB1) <= Expr_Value_R (HB2));
else
return
- (Expr_Value (LB1) > Expr_Value (HB1))
+ Expr_Value (LB1) > Expr_Value (HB1)
or else
- (Expr_Value (LB2) <= Expr_Value (LB1)
- and then
- Expr_Value (HB1) <= Expr_Value (HB2));
+ (Expr_Value (LB2) <= Expr_Value (LB1)
+ and then Expr_Value (HB1) <= Expr_Value (HB2));
end if;
end;
end if;
-- Access types
elsif Is_Access_Type (T1) then
- return (not Is_Constrained (T2)
- or else (Subtypes_Statically_Match
- (Designated_Type (T1), Designated_Type (T2))))
+ return
+ (not Is_Constrained (T2)
+ or else Subtypes_Statically_Match
+ (Designated_Type (T1), Designated_Type (T2)))
and then not (Can_Never_Be_Null (T2)
and then not Can_Never_Be_Null (T1));
-- All other cases
else
- return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
- or else Subtypes_Statically_Match (T1, T2, Formal_Derived_Matching);
+ return
+ (Is_Composite_Type (T1) and then not Is_Constrained (T2))
+ or else Subtypes_Statically_Match
+ (T1, T2, Formal_Derived_Matching);
end if;
end Subtypes_Statically_Compatible;
-- In addition, in GNAT, the object size (Esize) values of the types must
-- match if they are set (unless checking an actual for a formal derived
-- type). The use of 'Object_Size can cause this to be false even if the
- -- types would otherwise match in the RM sense.
+ -- types would otherwise match in the Ada 95 RM sense, but this deviation
+ -- is adopted by AI12-059 which introduces Object_Size in Ada 2020.
function Subtypes_Statically_Match
(T1 : Entity_Id;
-- No match if sizes different (from use of 'Object_Size). This test
-- is excluded if Formal_Derived_Matching is True, as the base types
- -- can be different in that case and typically have different sizes
- -- (and Esizes can be set when Frontend_Layout_On_Target is True).
+ -- can be different in that case and typically have different sizes.
elsif not Formal_Derived_Matching
and then Known_Static_Esize (T1)
else
if not Is_OK_Static_Subtype (T1)
- or else not Is_OK_Static_Subtype (T2)
+ or else
+ not Is_OK_Static_Subtype (T2)
then
return False;
- -- If either type has constraint error bounds, then say that
- -- they match to avoid junk cascaded errors here.
-
- elsif not Is_OK_Static_Subtype (T1)
- or else not Is_OK_Static_Subtype (T2)
- then
- return True;
-
elsif Is_Real_Type (T1) then
return
- (Expr_Value_R (LB1) = Expr_Value_R (LB2))
+ Expr_Value_R (LB1) = Expr_Value_R (LB2)
and then
- (Expr_Value_R (HB1) = Expr_Value_R (HB2));
+ Expr_Value_R (HB1) = Expr_Value_R (HB2);
else
return
elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
+ -- Handle derivations of private subtypes. For example S1 statically
+ -- matches the full view of T1 in the following example:
+
+ -- type T1(<>) is new Root with private;
+ -- subtype S1 is new T1;
+ -- overriding proc P1 (P : S1);
+ -- private
+ -- type T1 (D : Disc) is new Root with ...
+
+ if Ekind (T2) = E_Record_Subtype_With_Private
+ and then not Has_Discriminants (T2)
+ and then Partial_View_Has_Unknown_Discr (T1)
+ and then Etype (T2) = T1
+ then
+ return True;
+
+ elsif Ekind (T1) = E_Record_Subtype_With_Private
+ and then not Has_Discriminants (T1)
+ and then Partial_View_Has_Unknown_Discr (T2)
+ and then Etype (T1) = T2
+ then
+ return True;
+
-- Because of view exchanges in multiple instantiations, conformance
-- checking might try to match a partial view of a type with no
-- discriminants with a full view that has defaulted discriminants.
-- which must exist because we know that the two subtypes have the
-- same base type.
- if Has_Discriminants (T1) /= Has_Discriminants (T2) then
+ elsif Has_Discriminants (T1) /= Has_Discriminants (T2) then
if In_Instance then
if Is_Private_Type (T2)
and then Present (Full_View (T2))
end if;
declare
- DL1 : constant Elist_Id := Discriminant_Constraint (T1);
- DL2 : constant Elist_Id := Discriminant_Constraint (T2);
+
+ function Original_Discriminant_Constraint
+ (Typ : Entity_Id) return Elist_Id;
+ -- Returns Typ's discriminant constraint, or if the constraint
+ -- is inherited from an ancestor type, then climbs the parent
+ -- types to locate and return the constraint farthest up the
+ -- parent chain that Typ's constraint is ultimately inherited
+ -- from (stopping before a parent that doesn't impose a constraint
+ -- or a parent that has new discriminants). This ensures a proper
+ -- result from the equality comparison of Elist_Ids below (as
+ -- otherwise, derived types that inherit constraints may appear
+ -- to be unequal, because each level of derivation can have its
+ -- own copy of the constraint).
+
+ function Original_Discriminant_Constraint
+ (Typ : Entity_Id) return Elist_Id
+ is
+ begin
+ if not Has_Discriminants (Typ) then
+ return No_Elist;
+
+ -- If Typ is not a derived type, then directly return the
+ -- its constraint.
+
+ elsif not Is_Derived_Type (Typ) then
+ return Discriminant_Constraint (Typ);
+
+ -- If the parent type doesn't have discriminants, doesn't
+ -- have a constraint, or has new discriminants, then stop
+ -- and return Typ's constraint.
+
+ elsif not Has_Discriminants (Etype (Typ))
+
+ -- No constraint on the parent type
+
+ or else not Present (Discriminant_Constraint (Etype (Typ)))
+ or else Is_Empty_Elmt_List
+ (Discriminant_Constraint (Etype (Typ)))
+
+ -- The parent type defines new discriminants
+
+ or else
+ (Is_Base_Type (Etype (Typ))
+ and then Present (Discriminant_Specifications
+ (Parent (Etype (Typ)))))
+ then
+ return Discriminant_Constraint (Typ);
+
+ -- Otherwise, make a recursive call on the parent type
+
+ else
+ return Original_Discriminant_Constraint (Etype (Typ));
+ end if;
+ end Original_Discriminant_Constraint;
+
+ -- Local variables
+
+ DL1 : constant Elist_Id := Original_Discriminant_Constraint (T1);
+ DL2 : constant Elist_Id := Original_Discriminant_Constraint (T2);
DA1 : Elmt_Id;
DA2 : Elmt_Id;
then
return False;
- -- If either expression raised a constraint error,
+ -- If either expression raised a Constraint_Error,
-- consider the expressions as matching, since this
-- helps to prevent cascading errors.
if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
return False;
- elsif Ekind_In (T1, E_Access_Subprogram_Type,
- E_Anonymous_Access_Subprogram_Type)
+ elsif Ekind (T1) in E_Access_Subprogram_Type
+ | E_Anonymous_Access_Subprogram_Type
then
return
Subtype_Conformant
end if;
end Test;
+ ---------------------
+ -- Test_Comparison --
+ ---------------------
+
+ procedure Test_Comparison
+ (Op : Node_Id;
+ Assume_Valid : Boolean;
+ True_Result : out Boolean;
+ False_Result : out Boolean)
+ is
+ Left : constant Node_Id := Left_Opnd (Op);
+ Left_Typ : constant Entity_Id := Etype (Left);
+ Orig_Op : constant Node_Id := Original_Node (Op);
+
+ procedure Replacement_Warning (Msg : String);
+ -- Emit a warning on a comparison that can be replaced by '='
+
+ -------------------------
+ -- Replacement_Warning --
+ -------------------------
+
+ procedure Replacement_Warning (Msg : String) is
+ begin
+ if Constant_Condition_Warnings
+ and then Comes_From_Source (Orig_Op)
+ and then Is_Integer_Type (Left_Typ)
+ and then not Error_Posted (Op)
+ and then not Has_Warnings_Off (Left_Typ)
+ and then not In_Instance
+ then
+ Error_Msg_N (Msg, Op);
+ end if;
+ end Replacement_Warning;
+
+ -- Local variables
+
+ Res : constant Compare_Result :=
+ Compile_Time_Compare (Left, Right_Opnd (Op), Assume_Valid);
+
+ -- Start of processing for Test_Comparison
+
+ begin
+ case N_Op_Compare (Nkind (Op)) is
+ when N_Op_Eq =>
+ True_Result := Res = EQ;
+ False_Result := Res = LT or else Res = GT or else Res = NE;
+
+ when N_Op_Ge =>
+ True_Result := Res in Compare_GE;
+ False_Result := Res = LT;
+
+ if Res = LE and then Nkind (Orig_Op) = N_Op_Ge then
+ Replacement_Warning
+ ("can never be greater than, could replace by ""'=""?c?");
+ end if;
+
+ when N_Op_Gt =>
+ True_Result := Res = GT;
+ False_Result := Res in Compare_LE;
+
+ when N_Op_Le =>
+ True_Result := Res in Compare_LE;
+ False_Result := Res = GT;
+
+ if Res = GE and then Nkind (Orig_Op) = N_Op_Le then
+ Replacement_Warning
+ ("can never be less than, could replace by ""'=""?c?");
+ end if;
+
+ when N_Op_Lt =>
+ True_Result := Res = LT;
+ False_Result := Res in Compare_GE;
+
+ when N_Op_Ne =>
+ True_Result := Res = NE or else Res = GT or else Res = LT;
+ False_Result := Res = EQ;
+ end case;
+ end Test_Comparison;
+
---------------------------------
-- Test_Expression_Is_Foldable --
---------------------------------
Set_Etype (N, Any_Type);
return;
- -- If operand raises constraint error, then replace node N with the
- -- raise constraint error node, and we are obviously not foldable.
+ -- If operand raises Constraint_Error, then replace node N with the
+ -- raise Constraint_Error node, and we are obviously not foldable.
-- Note that this replacement inherits the Is_Static_Expression flag
-- from the operand.
return;
-- Here we have the case of an operand whose type is OK, which is
- -- static, and which does not raise constraint error, we can fold.
+ -- static, and which does not raise Constraint_Error, we can fold.
else
Set_Is_Static_Expression (N);
Set_Etype (N, Any_Type);
return;
- -- If left operand raises constraint error, then replace node N with the
+ -- If left operand raises Constraint_Error, then replace node N with the
-- Raise_Constraint_Error node, and we are obviously not foldable.
-- Is_Static_Expression is set from the two operands in the normal way,
-- and we check the right operand if it is in a non-static context.
return;
-- Else result is static and foldable. Both operands are static, and
- -- neither raises constraint error, so we can definitely fold.
+ -- neither raises Constraint_Error, so we can definitely fold.
else
Set_Is_Static_Expression (N);
pragma Warnings (Off, Assume_Valid);
-- For now Assume_Valid is unreferenced since the current implementation
- -- always returns Unknown if N is not a compile time known value, but we
+ -- always returns Unknown if N is not a compile-time-known value, but we
-- keep the parameter to allow for future enhancements in which we try
-- to get the information in the variable case as well.
begin
+ -- If an error was posted on expression, then return Unknown, we do not
+ -- want cascaded errors based on some false analysis of a junk node.
+
+ if Error_Posted (N) then
+ return Unknown;
+
+ -- Expression that raises Constraint_Error is an odd case. We certainly
+ -- do not want to consider it to be in range. It might make sense to
+ -- consider it always out of range, but this causes incorrect error
+ -- messages about static expressions out of range. So we just return
+ -- Unknown, which is always safe.
+
+ elsif Raises_Constraint_Error (N) then
+ return Unknown;
+
-- Universal types have no range limits, so always in range
- if Typ = Universal_Integer or else Typ = Universal_Real then
+ elsif Typ = Universal_Integer or else Typ = Universal_Real then
return In_Range;
-- Never known if not scalar type. Don't know if this can actually
-- Never known if this is a generic type, since the bounds of generic
-- types are junk. Note that if we only checked for static expressions
- -- (instead of compile time known values) below, we would not need this
+ -- (instead of compile-time-known values) below, we would not need this
-- check, because values of a generic type can never be static, but they
-- can be known at compile time.
elsif Is_Generic_Type (Typ) then
return Unknown;
- -- Never known unless we have a compile time known value
-
- elsif not Compile_Time_Known_Value (N) then
- return Unknown;
-
- -- General processing with a known compile time value
+ -- Case of a known compile time value, where we can check if it is in
+ -- the bounds of the given type.
- else
+ elsif Compile_Time_Known_Value (N) then
declare
Lo : Node_Id;
Hi : Node_Id;
end if;
end if;
end;
+
+ -- Here for value not known at compile time. Case of expression subtype
+ -- is Typ or is a subtype of Typ, and we can assume expression is valid.
+ -- In this case we know it is in range without knowing its value.
+
+ elsif Assume_Valid
+ and then (Etype (N) = Typ or else Is_Subtype_Of (Etype (N), Typ))
+ then
+ return In_Range;
+
+ -- Another special case. For signed integer types, if the target type
+ -- has Is_Known_Valid set, and the source type does not have a larger
+ -- size, then the source value must be in range. We exclude biased
+ -- types, because they bizarrely can generate out of range values.
+
+ elsif Is_Signed_Integer_Type (Etype (N))
+ and then Is_Known_Valid (Typ)
+ and then Esize (Etype (N)) <= Esize (Typ)
+ and then not Has_Biased_Representation (Etype (N))
+ then
+ return In_Range;
+
+ -- For all other cases, result is unknown
+
+ else
+ return Unknown;
end if;
end Test_In_Range;
--------------------
procedure Why_Not_Static (Expr : Node_Id) is
- N : constant Node_Id := Original_Node (Expr);
- Typ : Entity_Id;
+ N : constant Node_Id := Original_Node (Expr);
+ Typ : Entity_Id := Empty;
E : Entity_Id;
Alt : Node_Id;
Exp : Node_Id;
return;
end if;
- -- Test for constraint error raised
+ -- Test for Constraint_Error raised
if Raises_Constraint_Error (Expr) then
-- Entity name
- when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
+ when N_Expanded_Name
+ | N_Identifier
+ | N_Operator_Symbol
+ =>
E := Entity (N);
if Is_Named_Number (E) then
-- Binary operator
- when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
+ when N_Binary_Op
+ | N_Membership_Test
+ | N_Short_Circuit
+ =>
if Nkind (N) in N_Op_Shift then
Error_Msg_N
- ("!shift functions are never static (RM 4.9(6,18))", N);
+ ("!shift functions are never static (RM 4.9(6,18))", N);
else
Why_Not_Static (Left_Opnd (N));
Why_Not_Static (Right_Opnd (N));
-- Flag array cases
elsif Is_Array_Type (E) then
- if not Nam_In (Attribute_Name (N), Name_First,
- Name_Last,
- Name_Length)
+ if Attribute_Name (N)
+ not in Name_First | Name_Last | Name_Length
then
Error_Msg_N
("!static array attribute must be Length, First, or Last "
-- Aggregate
- when N_Aggregate | N_Extension_Aggregate =>
+ when N_Aggregate
+ | N_Extension_Aggregate
+ =>
Error_Msg_N ("!an aggregate is never static (RM 4.9)", N);
-- Range
when others =>
null;
-
end case;
end Why_Not_Static;
git://gcc.gnu.org / gcc.git / blobdiff