-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2017, 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 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:
-- (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
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.
-- 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 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;
-- 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 --
--------------------
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.
-- 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)
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
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;
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
-- 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;
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
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 worthwhile to optimize out the call.
- -- An exception is made for a literal in an if or case expression
-
- if (Nkind_In (Parent (N), N_If_Expression, N_Case_Expression_Alternative)
- or else Nkind (Parent (N)) not in N_Subexpr)
- and then not In_Any_Integer_Context
+ -- 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 --
---------------------
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
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 (Expr) then
Set_Raises_Constraint_Error (N, True);
-- 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
-------------------------------
-- 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
if Nkind (Expr) = N_String_Literal then
return UI_From_Int (String_Length (Strval (Expr)));
+ -- 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.
+
+ elsif Ekind (Etype (Expr)) = E_String_Literal_Subtype then
+ return String_Literal_Length (Etype (Expr));
+
-- Second easy case, not constrained subtype, so no length
elsif not Is_Constrained (Etype (Expr)) then
if Is_Array_Type (Left_Typ)
and then Left_Typ /= Any_Composite
and then Number_Dimensions (Left_Typ) = 1
- and then Nkind_In (N, N_Op_Eq, N_Op_Ne)
+ and then Nkind (N) in N_Op_Eq | N_Op_Ne
then
if Raises_Constraint_Error (Left)
or else
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;
Test_Expression_Is_Foldable
(N, Left, Right, Is_Static_Expression, Fold);
- -- Only comparisons of scalars can give static results. A comparison
- -- of strings never yields a static result, even if both operands are
- -- static strings, except that as noted above, we allow equality and
+ -- 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.
-
- if Is_String_Type (Left_Typ)
- and then not Comes_From_Source (N)
- and then Nkind_In (N, N_Op_Eq, N_Op_Ne)
- then
- null;
+ -- ??? 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 (Left_Typ) then
Is_Static_Expression := False;
-- 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;
-- 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);
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);
- -- Otherwise must be character literal
+ -- The NULL access value
- else
- pragma Assert (Kind = N_Character_Literal);
+ elsif Kind = N_Null then
+ pragma Assert (Is_Access_Type (Underlying_Type (Etype (N)))
+ or else Error_Posted (N));
+ return Uint_0;
+
+ -- 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);
- -- Otherwise must be character literal
+ -- The NULL access value
- else
- pragma Assert (Kind = N_Character_Literal);
+ elsif Kind = N_Null then
+ pragma Assert (Is_Access_Type (Underlying_Type (Etype (N)))
+ or else Error_Posted (N));
+ Val := Uint_0;
+
+ -- 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;
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;
--------------------------
-- 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);
--------------------
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;
-------------------------
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
-- 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
-- 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.
- -- ??? Frontend_Layout_On_Target used to set Esizes but this is no
- -- longer the case, consider removing the last test below.
elsif not Formal_Derived_Matching
and then Known_Static_Esize (T1)
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
- -- A generic actual type is declared through a subtype declaration
- -- and may have an inconsistent indication of the presence of
- -- discriminants, so check the type it renames.
-
- if Is_Generic_Actual_Type (T1)
- and then not Has_Discriminants (Etype (T1))
- and then not Has_Discriminants (T2)
- then
- return True;
-
- elsif In_Instance then
+ elsif Has_Discriminants (T1) /= Has_Discriminants (T2) then
+ if In_Instance then
if Is_Private_Type (T2)
and then Present (Full_View (T2))
and then Has_Discriminants (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
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.
if Error_Posted (N) then
return Unknown;
- -- Expression that raises constraint error is an odd case. We certainly
+ -- 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
-- 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.
return;
end if;
- -- Test for constraint error raised
+ -- Test for Constraint_Error raised
if Raises_Constraint_Error (Expr) then
-- 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 "
git://gcc.gnu.org / gcc.git / blobdiff