+2014-07-29 Robert Dewar <dewar@adacore.com>
+
+ * sem_aggr.adb (Resolve_Array_Aggregate): Change Is_Static_Range
+ to Is_OK_Static_Range.
+ * sem_attr.adb (Eval_Attribute): Make sure we properly flag
+ static attributes (Eval_Attribute, case Size): Handle size of
+ zero properly (Eval_Attribute, case Value_Size): Handle size of
+ zero properly.
+ * sem_ch13.adb: Minor reformatting.
+ * sem_ch3.adb (Process_Range_Expr_In_Decl): Change
+ Is_Static_Range to Is_OK_Static_Range.
+ * sem_eval.adb (Eval_Case_Expression): Total rewrite, was
+ wrong in several ways (Is_Static_Range): Moved here from spec
+ (Is_Static_Subtype): Moved here from spec Change some incorrect
+ Is_Static_Subtype calls to Is_OK_Static_Subtype.
+ * sem_eval.ads: Add comments to section on
+ Is_Static_Expression/Raises_Constraint_Error (Is_OK_Static_Range):
+ Add clarifying comments (Is_Static_Range): Moved to body
+ (Is_Statically_Unevaluated): New function.
+ * sem_util.ads, sem_util.adb (Is_Preelaborable_Expression): Change
+ Is_Static_Range to Is_OK_Static_Range.
+ * sinfo.ads: Additional commments for Is_Static_Expression noting
+ that clients should almost always use Is_OK_Static_Expression
+ instead. Many other changes throughout front end units to obey
+ this rule.
+ * tbuild.ads, tbuild.adb (New_Occurrence_Of): Set Is_Static_Expression
+ for enumeration literal.
+ * exp_ch5.adb, sem_intr.adb, sem_ch5.adb, exp_attr.adb, exp_ch9.adb,
+ lib-writ.adb, sem_ch9.adb, einfo.ads, checks.adb, checks.ads,
+ sem_prag.adb, sem_ch12.adb, freeze.adb, sem_res.adb, exp_ch4.adb,
+ exp_ch6.adb, sem_ch4.adb, sem_ch6.adb, exp_aggr.adb, sem_cat.adb:
+ Replace all occurrences of Is_Static_Expression by
+ Is_OK_Static_Expression.
+
2014-07-29 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch4.adb (Process_Transient_Object): Remove constant
-- First special case, if the source type is already within the range
-- of the target type, then no check is needed (probably we should have
-- stopped Do_Range_Check from being set in the first place, but better
- -- late than never in preventing junk code.
+ -- late than never in preventing junk code and junk flag settings.
if In_Subrange_Of (Source_Type, Target_Type)
and then not
(Is_Floating_Point_Type (Source_Type) and Check_Float_Overflow)
then
+ Set_Do_Range_Check (N, False);
return;
end if;
- -- We need a check, so force evaluation of the node, so that it does
- -- not get evaluated twice (once for the check, once for the actual
- -- reference). Such a double evaluation is always a potential source
- -- of inefficiency, and is functionally incorrect in the volatile case.
+ -- Here a check is needed. If the expander is not active, or if we are
+ -- in GNATProve mode, then simply set the Do_Range_Check flag and we
+ -- are done. In both these cases, we just want to see the range check
+ -- flag set, we do not want to generate the explicit range check code.
+
+ if GNATprove_Mode or else not Expander_Active then
+ Set_Do_Range_Check (N, True);
+ return;
+ end if;
+
+ -- Here we will generate an explicit range check, so we don't want to
+ -- set the Do_Range check flag, since the range check is taken care of
+ -- by the code we will generate.
+
+ Set_Do_Range_Check (N, False);
+
+ -- Force evaluation of the node, so that it does not get evaluated twice
+ -- (once for the check, once for the actual reference). Such a double
+ -- evaluation is always a potential source of inefficiency, and is
+ -- functionally incorrect in the volatile case.
if not Is_Entity_Name (N) or else Treat_As_Volatile (Entity (N)) then
Force_Evaluation (N);
--------------------------
procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is
- Stat : constant Boolean := Is_Static_Expression (R_Cno);
+ Stat : constant Boolean := Is_OK_Static_Expression (R_Cno);
Typ : constant Entity_Id := Etype (R_Cno);
begin
if Lo = No_Uint or else Hi = No_Uint then
return False;
- elsif Is_Static_Subtype (Etype (N)) then
+ elsif Is_OK_Static_Subtype (Etype (N)) then
return Lo >= Expr_Value (Type_Low_Bound (Rtyp))
and then
Hi <= Expr_Value (Type_High_Bound (Rtyp));
-- The Reason parameter is the exception code to be used for the exception
-- if raised.
--
- -- Note on the relation of this routine to the Do_Range_Check flag. Mostly
- -- for historical reasons, we often set the Do_Range_Check flag and then
- -- later we call Generate_Range_Check if this flag is set. Most probably we
- -- could eliminate this intermediate setting of the flag (historically the
- -- back end dealt with range checks, using this flag to indicate if a check
- -- was required, then we moved checks into the front end).
+ -- Note: if the expander is not active, or if we are in GNATprove mode,
+ -- then we do not generate explicit range code. Instead we just turn the
+ -- Do_Range_Check flag on, since in these cases that's what we want to see
+ -- in the tree (GNATprove in particular depends on this flag being set). If
+ -- we generate the actual range check, then we make sure the flag is off,
+ -- since the code we generate takes complete care of the check.
+ --
+ -- Historical note: We used to just pass ono the Do_Range_Check flag to the
+ -- back end to generate the check, but now in code generation mode we never
+ -- have this flag set, since the front end takes care of the check. The
+ -- normal processing flow now is that the analyzer typically turns on the
+ -- Do_Range_Check flag, and if it is set, this routine is called, which
+ -- turns the flag off in code generation mode.
procedure Generate_Index_Checks (N : Node_Id);
-- This procedure is called to generate index checks on the subscripts for
-- include only the components corresponding to these discriminants.
-- Has_Static_Predicate (Flag269)
--- Defined in all types and subtypes. Set if the type (which must be
--- a discrete, real, or string subtype) has a static predicate, i.e. a
--- predicate whose expression is predicate-static. This can result from
--- use of a Predicate, Static_Predicate, or Dynamic_Predicate aspect. We
--- can distinguish these cases by testing Has_Static_Predicate_Aspect
--- and Has_Dynamic_Predicate_Aspect. See description of the latter flag
--- for further information on dynamic predicates which are also static.
+-- Defined in all types and subtypes. Set if the type (which must be a
+-- scalar type) has a predicate whose expression is predicate-static.
+-- This can result from use of any of a Predicate, Static_Predicate, or
+-- Dynamic_Predicate aspect. We can distinguish these cases by testing
+-- Has_Static_Predicate_Aspect and Has_Dynamic_Predicate_Aspect. See
+-- description of the latter flag for further information on dynamic
+-- predicates which are also static.
-- Has_Static_Predicate_Aspect (Flag259)
-- Defined in all types and subtypes. Set if a Static_Predicate aspect
begin
Index := First_Index (Itype);
while Present (Index) loop
- if not Is_Static_Subtype (Etype (Index)) then
+ if not Is_OK_Static_Subtype (Etype (Index)) then
Needs_Type := True;
exit;
else
Get_Index_Bounds (First_Index (Typ), L1, H1);
Get_Index_Bounds (First_Index (Obj_Type), L2, H2);
- if not Is_Static_Expression (L1)
- or else not Is_Static_Expression (L2)
- or else not Is_Static_Expression (H1)
- or else not Is_Static_Expression (H2)
+ if not Is_OK_Static_Expression (L1) or else
+ not Is_OK_Static_Expression (L2) or else
+ not Is_OK_Static_Expression (H1) or else
+ not Is_OK_Static_Expression (H2)
then
return False;
else
-- it here.
elsif Do_Range_Check (First (Exprs)) then
- Set_Do_Range_Check (First (Exprs), False);
Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
end if;
end Val;
elsif Nkind (Expr) /= N_Error then
Apply_Constraint_Check (Expr, Typ);
- -- If the expression has been marked as requiring a range
- -- check, generate it now and reset the flag.
+ -- Deal with possible range check
if Do_Range_Check (Expr) then
- Set_Do_Range_Check (Expr, False);
- if not Suppress_Assignment_Checks (N) then
+ -- If assignment checks are suppressed, turn off flag
+
+ if Suppress_Assignment_Checks (N) then
+ Set_Do_Range_Check (Expr, False);
+
+ -- Otherwise generate the range check
+
+ else
Generate_Range_Check
(Expr, Typ, CE_Range_Check_Failed);
end if;
Apply_Constraint_Check (Exp, T, No_Sliding => True);
if Do_Range_Check (Exp) then
- Set_Do_Range_Check (Exp, False);
Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
end if;
(Exp, DesigT, No_Sliding => False);
if Do_Range_Check (Exp) then
- Set_Do_Range_Check (Exp, False);
Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
end if;
end if;
Nkind (Parent (Entity (Dval))) = N_Object_Declaration
and then Present (Expression (Parent (Entity (Dval))))
and then not
- Is_Static_Expression
+ Is_OK_Static_Expression
(Expression (Parent (Entity (Dval))))
then
exit Discr_Loop;
-- integer type.
Set_Do_Overflow_Check (N, False);
+
if not Is_Descendent_Of_Address (Etype (Expr))
and then not Is_Descendent_Of_Address (Target_Type)
then
-- First deal with generation of range check if required
if Do_Range_Check (Rhs) then
- Set_Do_Range_Check (Rhs, False);
Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed);
end if;
function Hi_Val (N : Node_Id) return Node_Id is
begin
- if Is_Static_Expression (N) then
+ if Is_OK_Static_Expression (N) then
return New_Copy (N);
else
pragma Assert (Nkind (N) = N_Range);
function Lo_Val (N : Node_Id) return Node_Id is
begin
- if Is_Static_Expression (N) then
+ if Is_OK_Static_Expression (N) then
return New_Copy (N);
else
pragma Assert (Nkind (N) = N_Range);
if Do_Range_Check (Actual)
and then Ekind (Formal) = E_In_Parameter
then
- Set_Do_Range_Check (Actual, False);
Generate_Range_Check
(Actual, Etype (Formal), CE_Range_Check_Failed);
end if;
-- check, then generate it here.
if Do_Range_Check (Actual) then
- Set_Do_Range_Check (Actual, False);
Generate_Range_Check
(Actual, Etype (Formal), CE_Range_Check_Failed);
end if;
if Present (Taskdef)
and then Has_Storage_Size_Pragma (Taskdef)
and then
- Is_Static_Expression
+ Is_OK_Static_Expression
(Expression
(First (Pragma_Argument_Associations
(Get_Rep_Pragma (TaskId, Name_Storage_Size)))))
if Has_Default_Initialization
or else
(Has_Init_Expression (Decl)
- and then
- (No (Expression (Decl))
- or else not
- (Is_Static_Expression (Expression (Decl))
- or else
- Nkind (Expression (Decl)) = N_Null)))
+ and then
+ (No (Expression (Decl))
+ or else not
+ (Is_OK_Static_Expression (Expression (Decl))
+ or else
+ Nkind (Expression (Decl)) = N_Null)))
then
Error_Msg_NE
("Thread_Local_Storage variable& is "
Analyze_And_Resolve (Exp, Typ);
if Etype (Exp) /= Any_Type then
- if not Is_Static_Expression (Exp) then
+ if not Is_OK_Static_Expression (Exp) then
Error_Msg_Name_1 := Nam;
Flag_Non_Static_Expr
("aspect% requires static expression", Exp);
-- expression, see section "Handling of Default Expressions" in the
-- spec of package Sem for further details. Note that we have to make
-- sure that we actually have a real expression (if we have a subtype
- -- indication, we can't test Is_Static_Expression). However, we exclude
- -- the case of the prefix of an attribute of a static scalar subtype
- -- from this early return, because static subtype attributes should
- -- always cause freezing, even in default expressions, but the attribute
- -- may not have been marked as static yet (because in Resolve_Attribute,
- -- the call to Eval_Attribute follows the call of Freeze_Expression on
- -- the prefix).
+ -- indication, we can't test Is_OK_Static_Expression). However, we
+ -- exclude the case of the prefix of an attribute of a static scalar
+ -- subtype from this early return, because static subtype attributes
+ -- should always cause freezing, even in default expressions, but
+ -- the attribute may not have been marked as static yet (because in
+ -- Resolve_Attribute, the call to Eval_Attribute follows the call of
+ -- Freeze_Expression on the prefix).
if In_Spec_Exp
and then Nkind (N) in N_Subexpr
- and then not Is_Static_Expression (N)
+ and then not Is_OK_Static_Expression (N)
and then (Nkind (Parent (N)) /= N_Attribute_Reference
or else not (Is_Entity_Name (N)
and then Is_Type (Entity (N))
- and then Is_Static_Subtype (Entity (N))))
+ and then Is_OK_Static_Subtype (Entity (N))))
then
return;
end if;
begin
Ensure_Type_Is_SA (Etype (N));
- if Is_Static_Expression (N) then
+ if Is_OK_Static_Expression (N) then
return;
elsif Nkind (N) = N_Identifier then
with Restrict; use Restrict;
with Rident; use Rident;
with Scn; use Scn;
+with Sem_Eval; use Sem_Eval;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Snames; use Snames;
Write_Info_Name (Chars (Expr));
elsif Nkind (Expr) = N_Integer_Literal
- and then Is_Static_Expression (Expr)
+ and then Is_OK_Static_Expression (Expr)
then
Write_Info_Uint (Intval (Expr));
elsif Nkind (Expr) = N_String_Literal
- and then Is_Static_Expression (Expr)
+ and then Is_OK_Static_Expression (Expr)
then
Write_Info_Slit (Strval (Expr));
and then not Is_Private_Composite (Typ)
and then not Is_Bit_Packed_Array (Typ)
and then Nkind (Original_Node (Parent (N))) /= N_String_Literal
- and then Is_Static_Subtype (Component_Type (Typ))
+ and then Is_OK_Static_Subtype (Component_Type (Typ))
then
declare
Expr : Node_Id;
end if;
-- If the expression has been marked as requiring a range check,
- -- then generate it here.
+ -- then generate it here. It's a bit odd to be generating such
+ -- checks in the analyzer, but harmless since Generate_Range_Check
+ -- does nothing (other than making sure Do_Range_Check is set) if
+ -- the expander is not active.
if Do_Range_Check (Expr) then
- Set_Do_Range_Check (Expr, False);
Generate_Range_Check (Expr, Component_Typ, CE_Range_Check_Failed);
end if;
-- In SPARK, the choice must be static
- if not (Is_Static_Expression (Choice)
+ if not (Is_OK_Static_Expression (Choice)
or else (Nkind (Choice) = N_Range
- and then Is_Static_Range (Choice)))
+ and then Is_OK_Static_Range (Choice)))
then
Check_SPARK_Restriction
("choice should be static", Choice);
end if;
-- If the expression has been marked as requiring a range check, then
- -- generate it here.
+ -- generate it here. It's a bit odd to be generating such checks in
+ -- the analyzer, but harmless since Generate_Range_Check does nothing
+ -- (other than making sure Do_Range_Check is set) if the expander is
+ -- not active.
if Do_Range_Check (Expr) then
- Set_Do_Range_Check (Expr, False);
Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed);
end if;
procedure Standard_Attribute (Val : Int);
-- Used to process attributes whose prefix is package Standard which
-- yield values of type Universal_Integer. The attribute reference
- -- node is rewritten with an integer literal of the given value.
+ -- node is rewritten with an integer literal of the given value which
+ -- is marked as static.
procedure Unexpected_Argument (En : Node_Id);
-- Signal unexpected attribute argument (En is the argument)
Resolve (E1, Any_Integer);
Set_Etype (E1, Standard_Integer);
- if not Is_Static_Expression (E1)
+ if not Is_OK_Static_Expression (E1)
or else Raises_Constraint_Error (E1)
then
Flag_Non_Static_Expr
-- Check non-static subtype
- if not Is_Static_Subtype (P_Type) then
+ if not Is_OK_Static_Subtype (P_Type) then
Error_Attr_P ("prefix of % attribute must be a static subtype");
end if;
Check_Standard_Prefix;
Rewrite (N, Make_Integer_Literal (Loc, Val));
Analyze (N);
+ Set_Is_Static_Expression (N, True);
end Standard_Attribute;
-------------------------
end if;
end if;
- -- Deal with Ada 2005 attributes that are
+ -- Deal with Ada 2005 attributes that are implementation attributes
+ -- because they appear in a version of Ada before Ada 2005.
if Attribute_05 (Attr_Id) and then Ada_Version < Ada_2005 then
Check_Restriction (No_Implementation_Attributes, N);
Check_Standard_Prefix;
Rewrite (N, Make_String_Literal (Loc, "GNAT " & Gnat_Version_String));
Analyze_And_Resolve (N, Standard_String);
+ Set_Is_Static_Expression (N, True);
--------------------
-- Component_Size --
else
if not Is_Entity_Name (P)
or else (not Is_Object (Entity (P))
- and then
- Ekind (Entity (P)) /= E_Enumeration_Literal)
+ and then Ekind (Entity (P)) /= E_Enumeration_Literal)
then
Error_Attr_P
("prefix of % attribute must be " &
Resolve (E1, Any_Integer);
Set_Etype (E1, Standard_Integer);
- if not Is_Static_Expression (E1) then
+ if not Is_OK_Static_Expression (E1) then
Flag_Non_Static_Expr
("expression for parameter number must be static!", E1);
Error_Attr;
Make_String_Literal (Loc,
Strval => TN (TN'First .. TL)));
Analyze_And_Resolve (N, Standard_String);
+ Set_Is_Static_Expression (N, True);
end Target_Name;
----------------
Analyze_And_Resolve (E1, Any_Integer);
Set_Etype (N, RTE (RE_Address));
- -- Static expression case, check range and set appropriate type
+ if Is_Static_Expression (E1) then
+ Set_Is_Static_Expression (N, True);
+ end if;
+
+ -- OK static expression case, check range and set appropriate type
if Is_OK_Static_Expression (E1) then
Val := Expr_Value (E1);
Set_Etype (E1, Standard_Unsigned_64);
end if;
end if;
+
+ Set_Is_Static_Expression (N, True);
end To_Address;
------------
Check_Type;
Check_Not_Incomplete_Type;
Set_Etype (N, Standard_Boolean);
+ Set_Is_Static_Expression (N, True);
------------------------------
-- Universal_Literal_String --
Rewrite (N,
Make_String_Literal (Loc, End_String));
Analyze (N);
+ Set_Is_Static_Expression (N, True);
end;
end if;
end Universal_Literal_String;
Static : Boolean;
-- True if the result is Static. This is set by the general processing
-- to true if the prefix is static, and all expressions are static. It
- -- can be reset as processing continues for particular attributes
+ -- can be reset as processing continues for particular attributes. This
+ -- flag can still be True if the reference raises a constraint error.
+ -- Is_Static_Expression (N) is set to follow this value as it is set
+ -- and we could always reference this, but it is convenient to have a
+ -- simple short name to use, since it is frequently referenced.
Lo_Bound, Hi_Bound : Node_Id;
-- Expressions for low and high bounds of type or array index referenced
Lo_Bound := Type_Low_Bound (Ityp);
Hi_Bound := Type_High_Bound (Ityp);
+ -- If subtype is non-static, result is definitely non-static
+
if not Is_Static_Subtype (Ityp) then
Static := False;
+ Set_Is_Static_Expression (N, False);
+
+ -- Subtype is static, does it raise CE?
+
+ elsif not Is_OK_Static_Subtype (Ityp) then
+ Set_Raises_Constraint_Error (N);
end if;
end Set_Bounds;
-- Start of processing for Eval_Attribute
begin
+ -- Initialize result as non-static, will be reset if appropriate
+
+ Set_Is_Static_Expression (N, False);
+ Static := False;
+
-- Acquire first two expressions (at the moment, no attributes take more
-- than two expressions in any case).
-- the attribute to the type of the array, but we need a constrained
-- type for this, so we use the actual subtype if available.
- elsif Id = Attribute_First
- or else
- Id = Attribute_Last
- or else
+ elsif Id = Attribute_First or else
+ Id = Attribute_Last or else
Id = Attribute_Length
then
declare
if Is_Entity_Name (P)
and then Known_Alignment (Entity (P))
then
- Fold_Uint (N, Alignment (Entity (P)), False);
+ Fold_Uint (N, Alignment (Entity (P)), Static);
return;
else
P_Entity := Entity (P);
end if;
+ -- If we are asked to evaluate an attribute where the prefix is a
+ -- non-frozen generic actual type whose RM_Size is still set to zero,
+ -- then abandon the effort. It seems wrong that this can ever happen,
+ -- but we see it happen, so this is a defense! ???
+
+ if Is_Type (P_Entity)
+ and then (not Is_Frozen (P_Entity)
+ and then Is_Generic_Actual_Type (P_Entity)
+ and then RM_Size (P_Entity) = 0)
+ then
+ return;
+ end if;
+
-- At this stage P_Entity is the entity to which the attribute
-- is to be applied. This is usually simply the entity of the
-- prefix, except in some cases of attributes for objects, where
-- as described above, we apply the attribute to the object type.
+ -- Here is where we make sure that static attributes are properly
+ -- marked as such. These are attributes whose prefix is a static
+ -- scalar subtype, whose result is scalar, and whose arguments, if
+ -- present, are static scalar expressions. Note that such references
+ -- are static expressions even if they raise Constraint_Error.
+
+ -- For example, Boolean'Pos (1/0 = 0) is a static expression, even
+ -- though evaluating it raises constraint error. This means that a
+ -- declaration like:
+
+ -- X : constant := (if True then 1 else Boolean'Pos (1/0 = 0));
+
+ -- is legal, since here this expression appears in a statically
+ -- unevaluated position, so it does not actually raise an exception.
+
+ if Is_Scalar_Type (P_Entity)
+ and then (not Is_Generic_Type (P_Entity))
+ and then Is_Static_Subtype (P_Entity)
+ and then Is_Scalar_Type (Etype (N))
+ and then
+ (No (E1)
+ or else (Is_Static_Expression (E1)
+ and then Is_Scalar_Type (Etype (E1))))
+ and then
+ (No (E2)
+ or else (Is_Static_Expression (E2)
+ and then Is_Scalar_Type (Etype (E1))))
+ then
+ Static := True;
+ Set_Is_Static_Expression (N, True);
+ end if;
+
-- First foldable possibility is a scalar or array type (RM 4.9(7))
-- that is not generic (generic types are eliminated by RM 4.9(25)).
-- Note we allow non-static non-generic types at this stage as further
end if;
end if;
- -- Definite must be folded if the prefix is not a generic type,
- -- that is to say if we are within an instantiation. Same processing
- -- applies to the GNAT attributes Atomic_Always_Lock_Free,
- -- Has_Discriminants, Lock_Free, Type_Class, Has_Tagged_Value, and
- -- Unconstrained_Array.
+ -- Definite must be folded if the prefix is not a generic type, that
+ -- is to say if we are within an instantiation. Same processing applies
+ -- to the GNAT attributes Atomic_Always_Lock_Free, Has_Discriminants,
+ -- Lock_Free, Type_Class, Has_Tagged_Value, and Unconstrained_Array.
- elsif (Id = Attribute_Atomic_Always_Lock_Free
- or else
- Id = Attribute_Definite
- or else
- Id = Attribute_Has_Access_Values
- or else
- Id = Attribute_Has_Discriminants
- or else
- Id = Attribute_Has_Tagged_Values
- or else
- Id = Attribute_Lock_Free
- or else
- Id = Attribute_Type_Class
- or else
- Id = Attribute_Unconstrained_Array
- or else
+ elsif (Id = Attribute_Atomic_Always_Lock_Free or else
+ Id = Attribute_Definite or else
+ Id = Attribute_Has_Access_Values or else
+ Id = Attribute_Has_Discriminants or else
+ Id = Attribute_Has_Tagged_Values or else
+ Id = Attribute_Lock_Free or else
+ Id = Attribute_Type_Class or else
+ Id = Attribute_Unconstrained_Array or else
Id = Attribute_Max_Alignment_For_Allocation)
and then not Is_Generic_Type (P_Entity)
then
end if;
if Is_Scalar_Type (P_Type) then
- Static := Is_OK_Static_Subtype (P_Type);
+ if not Is_Static_Subtype (P_Type) then
+ Static := False;
+ Set_Is_Static_Expression (N, False);
+ elsif not Is_OK_Static_Subtype (P_Type) then
+ Set_Raises_Constraint_Error (N);
+ end if;
-- Array case. We enforce the constrained requirement of (RM 4.9(7-8))
-- since we can't do anything with unconstrained arrays. In addition,
-- unconstrained arrays. Furthermore, it is essential to fold this
-- in the packed case, since otherwise the value will be incorrect.
- elsif Id = Attribute_Atomic_Always_Lock_Free
- or else
- Id = Attribute_Definite
- or else
- Id = Attribute_Has_Access_Values
- or else
- Id = Attribute_Has_Discriminants
- or else
- Id = Attribute_Has_Tagged_Values
- or else
- Id = Attribute_Lock_Free
- or else
- Id = Attribute_Type_Class
- or else
- Id = Attribute_Unconstrained_Array
- or else
+ elsif Id = Attribute_Atomic_Always_Lock_Free or else
+ Id = Attribute_Definite or else
+ Id = Attribute_Has_Access_Values or else
+ Id = Attribute_Has_Discriminants or else
+ Id = Attribute_Has_Tagged_Values or else
+ Id = Attribute_Lock_Free or else
+ Id = Attribute_Type_Class or else
+ Id = Attribute_Unconstrained_Array or else
Id = Attribute_Component_Size
then
Static := False;
+ Set_Is_Static_Expression (N, False);
elsif Id /= Attribute_Max_Alignment_For_Allocation then
if not Is_Constrained (P_Type)
-- which might otherwise accept non-static constants in contexts
-- where they are not legal.
- Static := Ada_Version >= Ada_95
- and then Statically_Denotes_Entity (P);
+ Static :=
+ Ada_Version >= Ada_95 and then Statically_Denotes_Entity (P);
+ Set_Is_Static_Expression (N, Static);
declare
- N : Node_Id;
+ Nod : Node_Id;
begin
- N := First_Index (P_Type);
+ Nod := First_Index (P_Type);
-- The expression is static if the array type is constrained
-- by given bounds, and not by an initial expression. Constant
if Root_Type (P_Type) /= Standard_String then
Static :=
Static and then not Is_Constr_Subt_For_U_Nominal (P_Type);
+ Set_Is_Static_Expression (N, Static);
+
end if;
- while Present (N) loop
- Static := Static and then Is_Static_Subtype (Etype (N));
+ while Present (Nod) loop
+ if not Is_Static_Subtype (Etype (Nod)) then
+ Static := False;
+ Set_Is_Static_Expression (N, False);
+ elsif not Is_OK_Static_Subtype (Etype (Nod)) then
+ Set_Raises_Constraint_Error (N);
+ end if;
-- If however the index type is generic, or derived from
-- one, attributes cannot be folded.
- if Is_Generic_Type (Root_Type (Etype (N)))
+ if Is_Generic_Type (Root_Type (Etype (Nod)))
and then Id /= Attribute_Component_Size
then
return;
end if;
- Next_Index (N);
+ Next_Index (Nod);
end loop;
end;
end if;
if not Is_Static_Expression (E) then
Static := False;
+ Set_Is_Static_Expression (N, False);
+ end if;
+
+ if Raises_Constraint_Error (E) then
+ Set_Raises_Constraint_Error (N);
end if;
-- If the result is not known at compile time, or is not of
Set_Raises_Constraint_Error (CE_Node);
Check_Expressions;
Rewrite (N, Relocate_Node (CE_Node));
- Set_Is_Static_Expression (N, Static);
+ Set_Raises_Constraint_Error (N, True);
return;
end if;
---------
when Attribute_Aft =>
- Fold_Uint (N, Aft_Value (P_Type), True);
+ Fold_Uint (N, Aft_Value (P_Type), Static);
---------------
-- Alignment --
-- Fold if alignment is set and not otherwise
if Known_Alignment (P_TypeA) then
- Fold_Uint (N, Alignment (P_TypeA), Is_Discrete_Type (P_TypeA));
+ Fold_Uint (N, Alignment (P_TypeA), Static);
end if;
end Alignment_Block;
-- static attribute in GNAT.
Analyze_And_Resolve (N, Standard_Boolean);
- Static := True;
+ Static := True;
+ Set_Is_Static_Expression (N, True);
end Atomic_Always_Lock_Free;
---------
when Attribute_Component_Size =>
if Known_Static_Component_Size (P_Type) then
- Fold_Uint (N, Component_Size (P_Type), False);
+ Fold_Uint (N, Component_Size (P_Type), Static);
end if;
-------------
when Attribute_Denorm =>
Fold_Uint
- (N, UI_From_Int (Boolean'Pos (Has_Denormals (P_Type))), True);
+ (N, UI_From_Int (Boolean'Pos (Has_Denormals (P_Type))), Static);
---------------------
-- Descriptor_Size --
------------
when Attribute_Digits =>
- Fold_Uint (N, Digits_Value (P_Type), True);
+ Fold_Uint (N, Digits_Value (P_Type), Static);
----------
-- Emax --
-- T'Emax = 4 * T'Mantissa
- Fold_Uint (N, 4 * Mantissa, True);
+ Fold_Uint (N, 4 * Mantissa, Static);
--------------
-- Enum_Rep --
-- static attribute in GNAT.
Analyze_And_Resolve (N, Standard_Boolean);
- Static := True;
+ Static := True;
+ Set_Is_Static_Expression (N, True);
end Lock_Free;
----------
then
Fold_Uint (N,
UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))),
- True);
+ Static);
end if;
-- One more case is where Hi_Bound and Lo_Bound are compile-time
(Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
is
when EQ =>
- Fold_Uint (N, Uint_1, False);
+ Fold_Uint (N, Uint_1, Static);
when GT =>
- Fold_Uint (N, Uint_0, False);
+ Fold_Uint (N, Uint_0, Static);
when LT =>
if Diff /= No_Uint then
- Fold_Uint (N, Diff + 1, False);
+ Fold_Uint (N, Diff + 1, Static);
end if;
when others =>
-- Always true for fixed-point
if Is_Fixed_Point_Type (P_Type) then
- Fold_Uint (N, True_Value, True);
+ Fold_Uint (N, True_Value, Static);
-- Floating point case
else
Fold_Uint (N,
UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)),
- True);
+ Static);
end if;
-------------------
if Is_Decimal_Fixed_Point_Type (P_Type)
and then Machine_Radix_10 (P_Type)
then
- Fold_Uint (N, Uint_10, True);
+ Fold_Uint (N, Uint_10, Static);
else
- Fold_Uint (N, Uint_2, True);
+ Fold_Uint (N, Uint_2, Static);
end if;
-- All floating-point type always have radix 2
else
- Fold_Uint (N, Uint_2, True);
+ Fold_Uint (N, Uint_2, Static);
end if;
----------------------
-- Always False for fixed-point
if Is_Fixed_Point_Type (P_Type) then
- Fold_Uint (N, False_Value, True);
+ Fold_Uint (N, False_Value, Static);
-- Else yield proper floating-point result
else
Fold_Uint
- (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)), True);
+ (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)),
+ Static);
end if;
------------------
begin
if Known_Esize (P_TypeA) then
- Fold_Uint (N, Esize (P_TypeA), True);
+ Fold_Uint (N, Esize (P_TypeA), Static);
end if;
end Machine_Size;
Siz := Siz + 1;
end loop;
- Fold_Uint (N, Siz, True);
+ Fold_Uint (N, Siz, Static);
end;
else
-- Floating-point Mantissa
else
- Fold_Uint (N, Mantissa, True);
+ Fold_Uint (N, Mantissa, Static);
end if;
---------
end if;
if Mech < 0 then
- Fold_Uint (N, UI_From_Int (Int (-Mech)), True);
+ Fold_Uint (N, UI_From_Int (Int (-Mech)), Static);
end if;
end;
-------------
when Attribute_Modulus =>
- Fold_Uint (N, Modulus (P_Type), True);
+ Fold_Uint (N, Modulus (P_Type), Static);
--------------------
-- Null_Parameter --
begin
if Known_Esize (P_TypeA) then
- Fold_Uint (N, Esize (P_TypeA), True);
+ Fold_Uint (N, Esize (P_TypeA), Static);
end if;
end Object_Size;
-- Scalar types are never passed by reference
when Attribute_Passed_By_Reference =>
- Fold_Uint (N, False_Value, True);
+ Fold_Uint (N, False_Value, Static);
---------
-- Pos --
---------
when Attribute_Pos =>
- Fold_Uint (N, Expr_Value (E1), True);
+ Fold_Uint (N, Expr_Value (E1), Static);
----------
-- Pred --
(Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
is
when EQ =>
- Fold_Uint (N, Uint_1, False);
+ Fold_Uint (N, Uint_1, Static);
when GT =>
- Fold_Uint (N, Uint_0, False);
+ Fold_Uint (N, Uint_0, Static);
when LT =>
if Diff /= No_Uint then
- Fold_Uint (N, Diff + 1, False);
+ Fold_Uint (N, Diff + 1, Static);
end if;
when others =>
---------
when Attribute_Ref =>
- Fold_Uint (N, Expr_Value (E1), True);
+ Fold_Uint (N, Expr_Value (E1), Static);
---------------
-- Remainder --
-----------
when Attribute_Scale =>
- Fold_Uint (N, Scale_Value (P_Type), True);
+ Fold_Uint (N, Scale_Value (P_Type), Static);
-------------
-- Scaling --
-- Size attribute returns the RM size. All scalar types can be folded,
-- as well as any types for which the size is known by the front end,
- -- including any type for which a size attribute is specified.
+ -- including any type for which a size attribute is specified. This is
+ -- one of the places where it is annoying that a size of zero means two
+ -- things (zero size for scalars, unspecified size for non-scalars).
when Attribute_Size | Attribute_VADS_Size => Size : declare
P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
begin
- if RM_Size (P_TypeA) /= Uint_0 then
+ if Is_Scalar_Type (P_TypeA) or else RM_Size (P_TypeA) /= Uint_0 then
-- VADS_Size case
if Present (S)
and then Is_OK_Static_Expression (Expression (S))
then
- Fold_Uint (N, Expr_Value (Expression (S)), True);
+ Fold_Uint (N, Expr_Value (Expression (S)), Static);
-- If no size is specified, then we simply use the object
-- size in the VADS_Size case (e.g. Natural'Size is equal
-- to Integer'Size, not one less).
else
- Fold_Uint (N, Esize (P_TypeA), True);
+ Fold_Uint (N, Esize (P_TypeA), Static);
end if;
end;
-- Normal case (Size) in which case we want the RM_Size
else
- Fold_Uint (N,
- RM_Size (P_TypeA),
- Static and then Is_Discrete_Type (P_TypeA));
+ Fold_Uint (N, RM_Size (P_TypeA), Static);
end if;
end if;
end Size;
Analyze_And_Resolve (N, Standard_Boolean);
Static := True;
+ Set_Is_Static_Expression (N, True);
end Unconstrained_Array;
-- Attribute Update is never static
-- Value_Size --
----------------
- -- The Value_Size attribute for a type returns the RM size of the
- -- type. This an always be folded for scalar types, and can also
- -- be folded for non-scalar types if the size is set.
+ -- The Value_Size attribute for a type returns the RM size of the type.
+ -- This an always be folded for scalar types, and can also be folded for
+ -- non-scalar types if the size is set. This is one of the places where
+ -- it is annoying that a size of zero means two things!
when Attribute_Value_Size => Value_Size : declare
P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
begin
- if RM_Size (P_TypeA) /= Uint_0 then
- Fold_Uint (N, RM_Size (P_TypeA), True);
+ if Is_Scalar_Type (P_TypeA) or else RM_Size (P_TypeA) /= Uint_0 then
+ Fold_Uint (N, RM_Size (P_TypeA), Static);
end if;
end Value_Size;
if Expr_Value_R (Type_High_Bound (P_Type)) <
Expr_Value_R (Type_Low_Bound (P_Type))
then
- Fold_Uint (N, Uint_0, True);
+ Fold_Uint (N, Uint_0, Static);
else
-- For floating-point, we have +N.dddE+nnn where length
Len := Len + 8;
end if;
- Fold_Uint (N, UI_From_Int (Len), True);
+ Fold_Uint (N, UI_From_Int (Len), Static);
end;
end if;
if Expr_Value (Type_High_Bound (P_Type)) <
Expr_Value (Type_Low_Bound (P_Type))
then
- Fold_Uint (N, Uint_0, True);
+ Fold_Uint (N, Uint_0, Static);
-- The non-null case depends on the specific real type
Fold_Uint
(N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type),
- True);
+ Static);
end if;
-- Discrete types
end loop;
end if;
- Fold_Uint (N, UI_From_Int (W), True);
+ Fold_Uint (N, UI_From_Int (W), Static);
end;
end if;
end if;
procedure Set_Boolean_Result (N : Node_Id; B : Boolean) is
Loc : constant Source_Ptr := Sloc (N);
-
begin
if B then
Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
else
Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
end if;
-
- Set_Is_Static_Expression (N);
end Set_Boolean_Result;
--------------------------------
loop
if Present (Expression (Component_Decl))
and then Nkind (Expression (Component_Decl)) /= N_Null
- and then not Is_Static_Expression (Expression (Component_Decl))
+ and then not Is_OK_Static_Expression (Expression (Component_Decl))
then
Error_Msg_Sloc := Sloc (Component_Decl);
Error_Msg_F
Discriminant_Spec := First (L);
while Present (Discriminant_Spec) loop
if Present (Expression (Discriminant_Spec))
- and then not Is_Static_Expression (Expression (Discriminant_Spec))
+ and then
+ not Is_OK_Static_Expression (Expression (Discriminant_Spec))
then
return False;
end if;
Expr2 := Expression (Parent (E2));
end if;
- if Is_Static_Expression (Expr1) then
-
- if not Is_Static_Expression (Expr2) then
+ if Is_OK_Static_Expression (Expr1) then
+ if not Is_OK_Static_Expression (Expr2) then
Check_Mismatch (True);
elsif Is_Discrete_Type (Etype (E1)) then
-- illegal specification of this aspect for a subtype now,
-- to prevent malformed rep_item chains.
- if (A_Id = Aspect_Input
- or else A_Id = Aspect_Output
- or else A_Id = Aspect_Read
- or else A_Id = Aspect_Write)
+ if (A_Id = Aspect_Input or else
+ A_Id = Aspect_Output or else
+ A_Id = Aspect_Read or else
+ A_Id = Aspect_Write)
and not Is_First_Subtype (E)
then
Error_Msg_N
-- The expression must be static
- elsif not Is_Static_Expression (Expr) then
+ elsif not Is_OK_Static_Expression (Expr) then
Flag_Non_Static_Expr
("aspect requires static expression!", Expr);
if Etype (Expr) = Any_Type then
return;
- elsif not Is_Static_Expression (Expr) then
+ elsif not Is_OK_Static_Expression (Expr) then
Flag_Non_Static_Expr
("Bit_Order requires static expression!", Expr);
Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range));
Uninstall_Discriminants_And_Pop_Scope (U_Ent);
- if not Is_Static_Expression (Expr) then
+ if not Is_OK_Static_Expression (Expr) then
Check_Restriction (Static_Priorities, Expr);
end if;
end if;
else
Analyze_And_Resolve (Expr, Standard_String);
- if not Is_Static_Expression (Expr) then
+ if not Is_OK_Static_Expression (Expr) then
Flag_Non_Static_Expr
("static string required for tag name!", Nam);
end if;
Preanalyze_Spec_Expression (Expr, Standard_Integer);
Uninstall_Discriminants_And_Pop_Scope (U_Ent);
- if not Is_Static_Expression (Expr) then
+ if not Is_OK_Static_Expression (Expr) then
Check_Restriction (Static_Priorities, Expr);
end if;
end if;
if Etype (Expr) = Any_Type then
return;
- elsif not Is_Static_Expression (Expr) then
+ elsif not Is_OK_Static_Expression (Expr) then
Flag_Non_Static_Expr
("Scalar_Storage_Order requires static expression!", Expr);
if Etype (Expr) = Any_Type then
return;
- elsif not Is_Static_Expression (Expr) then
+ elsif not Is_OK_Static_Expression (Expr) then
Flag_Non_Static_Expr
("small requires static expression!", Expr);
return;
-- ??? should allow static subtype with zero/one entry
elsif Etype (Choice) = Base_Type (Enumtype) then
- if not Is_Static_Expression (Choice) then
+ if not Is_OK_Static_Expression (Choice) then
Flag_Non_Static_Expr
("non-static expression used for choice!", Choice);
Err := True;
while Present (Alt) loop
Dep := Expression (Alt);
- if not Is_Static_Expression (Dep) then
+ if not Is_OK_Static_Expression (Dep) then
raise Non_Static;
elsif Is_True (Expr_Value (Dep)) then
function Hi_Val (N : Node_Id) return Uint is
begin
- if Is_Static_Expression (N) then
+ if Is_OK_Static_Expression (N) then
return Expr_Value (N);
else
pragma Assert (Nkind (N) = N_Range);
function Lo_Val (N : Node_Id) return Uint is
begin
- if Is_Static_Expression (N) then
+ if Is_OK_Static_Expression (N) then
return Expr_Value (N);
else
pragma Assert (Nkind (N) = N_Range);
-- Range case
if Nkind (N) = N_Range then
- if not Is_Static_Expression (Low_Bound (N))
+ if not Is_OK_Static_Expression (Low_Bound (N))
or else
- not Is_Static_Expression (High_Bound (N))
+ not Is_OK_Static_Expression (High_Bound (N))
then
raise Non_Static;
else
-- Static expression case
- elsif Is_Static_Expression (N) then
+ elsif Is_OK_Static_Expression (N) then
Val := Expr_Value (N);
return RList'(1 => REnt'(Val, Val));
-- For static subtype without predicates, get range
- elsif Is_Static_Subtype (Entity (N)) then
+ elsif Is_OK_Static_Subtype (Entity (N)) then
SLo := Expr_Value (Type_Low_Bound (Entity (N)));
SHi := Expr_Value (Type_High_Bound (Entity (N)));
return RList'(1 => REnt'(SLo, SHi));
-- issued elsewhere, since sizes of non-static array types
-- cannot be set implicitly or explicitly.
- if not Is_Static_Subtype (Ityp) then
+ if not Is_OK_Static_Subtype (Ityp) then
return;
end if;
while Present (X) loop
C := Etype (X);
- if not Is_Static_Subtype (C) then
+ if not Is_OK_Static_Subtype (C) then
Check_Restriction (Max_Tasks, N);
return Uint_0;
else
-- static, even if its bounds are static.
if Nkind (I) = N_Subtype_Indication
- and then not Is_Static_Subtype (Entity (Subtype_Mark (I)))
+ and then not Is_OK_Static_Subtype (Entity (Subtype_Mark (I)))
then
Set_Is_Non_Static_Subtype (Def_Id);
end if;
-- discrete type definition of a loop parameter specification.
if not In_Iter_Schm
- and then not Is_Static_Range (R)
+ and then not Is_OK_Static_Range (R)
then
Check_SPARK_Restriction ("range should be static", R);
end if;
-- case expression has not been fully analyzed yet because this may lead
-- to bogus errors.
- if Is_Static_Subtype (Exp_Type)
+ if Is_OK_Static_Subtype (Exp_Type)
and then Has_Static_Predicate_Aspect (Exp_Type)
and then In_Spec_Expression
then
-- Propagate staticness to loop range itself, in case the
-- corresponding subtype is static.
- if New_Lo /= Lo and then Is_Static_Expression (New_Lo) then
+ if New_Lo /= Lo and then Is_OK_Static_Expression (New_Lo) then
Rewrite (Low_Bound (R), New_Copy (New_Lo));
end if;
- if New_Hi /= Hi and then Is_Static_Expression (New_Hi) then
+ if New_Hi /= Hi and then Is_OK_Static_Expression (New_Hi) then
Rewrite (High_Bound (R), New_Copy (New_Hi));
end if;
end Process_Bounds;
elsif Is_Entity_Name (Orig_Expr)
and then Ekind (Entity (Orig_Expr)) = E_Constant
- and then Is_Static_Expression (Orig_Expr)
+ and then Is_OK_Static_Expression (Orig_Expr)
then
return OK;
else
if Is_Scalar_Type (Etype (Attr))
and then Is_Scalar_Type (Etype (Prefix (Attr)))
- and then Is_Static_Subtype (Etype (Prefix (Attr)))
+ and then
+ Is_OK_Static_Subtype (Etype (Prefix (Attr)))
then
Para := First (Expressions (Attr));
-- static function restricted.
elsif Kind = N_Attribute_Reference
- and then not Is_Static_Expression (N)
+ and then not Is_OK_Static_Expression (N)
and then not Is_Static_Function (N)
then
if Lock_Free_Given then
-- Non-static function calls restricted
elsif Kind = N_Function_Call
- and then not Is_Static_Expression (N)
+ and then not Is_OK_Static_Expression (N)
then
if Lock_Free_Given then
Error_Msg_N
goto Skip_LB;
end if;
- if Is_Static_Expression (LBR)
+ if Is_OK_Static_Expression (LBR)
and then Expr_Value (LBR) < LB
then
Error_Msg_Uint_1 := LB;
goto Skip_UB;
end if;
- if Is_Static_Expression (UBR)
+ if Is_OK_Static_Expression (UBR)
and then Expr_Value (UBR) > UB
then
Error_Msg_Uint_1 := UB;
V : Uint;
end record;
+ type Match_Result is (Match, No_Match, Non_Static);
+ -- Result returned from functions that test for a matching result. If the
+ -- operands are not OK_Static then Non_Static will be returned. Otherwise
+ -- Match/No_Match is returned depending on whether the match succeeds.
+
type CV_Cache_Array is array (CV_Range) of CV_Entry;
CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0));
-- Local Subprograms --
-----------------------
+ function Choice_Matches
+ (Expr : Node_Id;
+ Choice : Node_Id) return Match_Result;
+ -- Determines whether given value Expr matches the given Choice. The Expr
+ -- can be of 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). The choice can be a range, subtype name, subtype indication,
+ -- or expression. The returned result is Non_Static if Choice is not
+ -- OK_Static, otherwise either Match or No_Match is returned depending
+ -- on whether Choice matches Expr. This is used for case expression
+ -- alternatives, and also for membership tests. In each case, more
+ -- possibilities are tested than the syntax allows (e.g. membership allows
+ -- subtype indications and non-discrete types, and case allows an OTHERS
+ -- choice), but it does not matter, since we have already done a full
+ -- semantic and syntax check of the construct, so the extra possibilities
+ -- just will not arise for correct expressions.
+ --
+ -- Note: if Choice_Matches finds that a choice raises Constraint_Error, e.g
+ -- a reference to a type, one of whose bounds raises Constraint_Error, then
+ -- it also sets the Raises_Constraint_Error flag on the Choice itself.
+
+ function Choices_Match
+ (Expr : Node_Id;
+ Choices : List_Id) return Match_Result;
+ -- This function applies Choice_Matches to each element of Choices. If the
+ -- 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
+ -- (it is an error to make the call if these conditions are not met).
+
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
-- (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 Is_OK_Static_Choice (Choice : Node_Id) return Boolean;
+ -- Given a choice (from a case expression or membership test), returns
+ -- True if the choice is static and does not raise a Constraint_Error.
+
+ function Is_OK_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_OK_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
+ -- equivalent range attribute references already turned them into the
+ -- equivalent range). This differs from Is_OK_Static_Range (which is what
+ -- must be used by clients) in that it does not care whether the bounds
+ -- 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
procedure To_Bits (U : Uint; B : out Bits);
-- Converts a Uint value to a bit string of length B'Length
+ -----------------------------------------------
+ -- Check_Expression_Against_Static_Predicate --
+ -----------------------------------------------
+
+ procedure Check_Expression_Against_Static_Predicate
+ (Expr : Node_Id;
+ Typ : Entity_Id)
+ is
+ begin
+ -- Nothing to do if expression is not known at compile time, or the
+ -- type has no static predicate set (will be the case for all non-scalar
+ -- types, so no need to make a special test for that).
+
+ if not (Has_Static_Predicate (Typ)
+ and then Compile_Time_Known_Value (Expr))
+ then
+ return;
+ end if;
+
+ -- 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).
+
+ -- If we are not generating code, nothing more to do (why???)
+
+ if Operating_Mode < Generate_Code then
+ return;
+ end if;
+
+ -- If we have the real case, then for now, not implemented
+
+ if not Is_Discrete_Type (Typ) then
+ Error_Msg_N ("??real predicate not applied", Expr);
+ return;
+ end if;
+
+ -- If static predicate matches, nothing to do
+
+ if Choices_Match (Expr, Static_Predicate (Typ)) = Match then
+ return;
+ 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.
+
+ 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);
+
+ -- 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
+ -- predicate comes from a dynamic predicate aspect or not.
+
+ else
+ Error_Msg_NE
+ ("??expression fails predicate check on &", Expr, Typ);
+ end if;
+ end Check_Expression_Against_Static_Predicate;
------------------------------
-- Check_Non_Static_Context --
------------------------------
end if;
end Check_String_Literal_Length;
+ --------------------
+ -- Choice_Matches --
+ --------------------
+
+ function Choice_Matches
+ (Expr : Node_Id;
+ Choice : Node_Id) return Match_Result
+ is
+ Etyp : constant Entity_Id := Etype (Expr);
+ Val : Uint;
+ ValR : Ureal;
+ ValS : Node_Id;
+
+ begin
+ pragma Assert (Compile_Time_Known_Value (Expr));
+ pragma Assert (Is_Scalar_Type (Etyp) or else Is_String_Type (Etyp));
+
+ if not Is_OK_Static_Choice (Choice) then
+ Set_Raises_Constraint_Error (Choice);
+ return Non_Static;
+
+ -- Discrete type case
+
+ elsif Is_Discrete_Type (Etype (Expr)) then
+ Val := Expr_Value (Expr);
+
+ if Nkind (Choice) = N_Range then
+ if Val >= Expr_Value (Low_Bound (Choice))
+ and then
+ Val <= Expr_Value (High_Bound (Choice))
+ then
+ return Match;
+ else
+ return No_Match;
+ end if;
+
+ elsif Nkind (Choice) = N_Subtype_Indication
+ or else
+ (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
+ then
+ if Val >= Expr_Value (Type_Low_Bound (Etype (Choice)))
+ and then
+ Val <= Expr_Value (Type_High_Bound (Etype (Choice)))
+ then
+ return Match;
+ else
+ return No_Match;
+ end if;
+
+ elsif Nkind (Choice) = N_Others_Choice then
+ return Match;
+
+ else
+ if Val = Expr_Value (Choice) then
+ return Match;
+ else
+ return No_Match;
+ end if;
+ end if;
+
+ -- Real type case
+
+ elsif Is_Real_Type (Etype (Expr)) then
+ ValR := Expr_Value_R (Expr);
+
+ if Nkind (Choice) = N_Range then
+ if ValR >= Expr_Value_R (Low_Bound (Choice))
+ and then
+ ValR <= Expr_Value_R (High_Bound (Choice))
+ then
+ return Match;
+ else
+ return No_Match;
+ end if;
+
+ elsif Nkind (Choice) = N_Subtype_Indication
+ 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
+ ValR <= Expr_Value_R (Type_High_Bound (Etype (Choice)))
+ then
+ return Match;
+ else
+ return No_Match;
+ end if;
+
+ else
+ if ValR = Expr_Value_R (Choice) then
+ return Match;
+ else
+ return No_Match;
+ end if;
+ end if;
+
+ -- String type cases
+
+ else
+ pragma Assert (Is_String_Type (Etype (Expr)));
+ ValS := Expr_Value_S (Expr);
+
+ if Nkind (Choice) = N_Subtype_Indication
+ or else
+ (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
+ then
+ if not Is_Constrained (Etype (Choice)) then
+ return Match;
+
+ else
+ declare
+ Typlen : constant Uint :=
+ String_Type_Len (Etype (Choice));
+ Strlen : constant Uint :=
+ UI_From_Int (String_Length (Strval (ValS)));
+ begin
+ if Typlen = Strlen then
+ return Match;
+ else
+ return No_Match;
+ end if;
+ end;
+ end if;
+
+ else
+ if String_Equal (Strval (ValS), Strval (Expr_Value_S (Choice)))
+ then
+ return Match;
+ else
+ return No_Match;
+ end if;
+ end if;
+ end if;
+ end Choice_Matches;
+
+ -------------------
+ -- Choices_Match --
+ -------------------
+
+ function Choices_Match
+ (Expr : Node_Id;
+ Choices : List_Id) return Match_Result
+ is
+ Choice : Node_Id;
+ Result : Match_Result;
+
+ begin
+ Choice := First (Choices);
+ while Present (Choice) loop
+ Result := Choice_Matches (Expr, Choice);
+
+ if Result /= No_Match then
+ return Result;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ return No_Match;
+ end Choices_Match;
+
--------------------------
-- Compile_Time_Compare --
--------------------------
-- conditions when this is inappropriate.
if not (Full_Analysis
- or else (Is_Static_Expression (L)
+ or else (Is_OK_Static_Expression (L)
and then
- Is_Static_Expression (R)))
+ Is_OK_Static_Expression (R)))
then
return Unknown;
end if;
Apply_Compile_Time_Constraint_Error
(N, "division by zero", CE_Divide_By_Zero,
Warn => not Stat);
+ Set_Raises_Constraint_Error (N);
return;
+ -- Otherwise we can do the division
+
else
Result := Left_Int / Right_Int;
end if;
--------------------------
-- A conditional expression is static if all its conditions and dependent
- -- expressions are static.
+ -- expressions are static. Note that we do not care if the dependent
+ -- expressions raise CE, except for the one that will be selected.
procedure Eval_Case_Expression (N : Node_Id) is
- Alt : Node_Id;
- Choice : Node_Id;
- Is_Static : Boolean;
- Result : Node_Id;
- Val : Uint;
+ Alt : Node_Id;
+ Choice : Node_Id;
begin
- Result := Empty;
- Is_Static := True;
+ Set_Is_Static_Expression (N, False);
- if Is_Static_Expression (Expression (N)) then
- Val := Expr_Value (Expression (N));
- else
+ if not Is_Static_Expression (Expression (N)) then
Check_Non_Static_Context (Expression (N));
- Is_Static := False;
+ return;
end if;
+ -- First loop, make sure all the alternatives are static expressions
+ -- 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
+ -- exception, so we don't even try to evaluate if that is the case.
+
Alt := First (Alternatives (N));
+ while Present (Alt) loop
- Search : while Present (Alt) loop
- if not Is_Static
- or else not Is_Static_Expression (Expression (Alt))
- then
- Check_Non_Static_Context (Expression (Alt));
- Is_Static := False;
+ -- The expression must be static, but we don't care at this stage
+ -- if it raises Constraint_Error (the alternative might not match,
+ -- in which case the expression is statically unevaluated anyway).
- else
- Choice := First (Discrete_Choices (Alt));
- while Present (Choice) loop
- if Nkind (Choice) = N_Others_Choice then
- Result := Expression (Alt);
- exit Search;
+ if not Is_Static_Expression (Expression (Alt)) then
+ Check_Non_Static_Context (Expression (Alt));
+ return;
+ end if;
- elsif Expr_Value (Choice) = Val then
- Result := Expression (Alt);
- exit Search;
+ -- The choices of a case always have to be static, and cannot raise
+ -- an exception. If this condition is not met, then the expression
+ -- is plain illegal, so just abandon evaluation attempts. No need
+ -- to check non-static context when we have something illegal anyway.
- else
- Next (Choice);
- end if;
- end loop;
+ if not Is_OK_Static_Choice_List (Discrete_Choices (Alt)) then
+ return;
end if;
Next (Alt);
- end loop Search;
+ end loop;
- if Is_Static then
- Rewrite (N, Relocate_Node (Result));
+ -- OK, if the above loop gets through it means that all choices are OK
+ -- static (don't raise exceptions), so the whole case is static, and we
+ -- can find the matching alternative.
+
+ Set_Is_Static_Expression (N);
+
+ -- Now to deal with propagating a possible constraint error
+
+ -- If the selecting expression raises CE, propagate and we are done
+
+ if Raises_Constraint_Error (Expression (N)) then
+ Set_Raises_Constraint_Error (N);
+
+ -- Otherwise we need to check the alternatives to find the matching
+ -- one. CE's in other than the matching one are not relevant. But we
+ -- do need to check the matching one. Unlike the first loop, we do not
+ -- have to go all the way through, when we find the matching one, quit.
else
- Set_Is_Static_Expression (N, False);
+ Alt := First (Alternatives (N));
+ Search : loop
+
+ -- We must find a match among the alternatives, If not this must
+ -- be due to other errors, so just ignore, leaving as non-static.
+
+ if No (Alt) then
+ Set_Is_Static_Expression (N, False);
+ return;
+ end if;
+
+ -- Otherwise loop through choices of this alternative
+
+ Choice := First (Discrete_Choices (Alt));
+ while Present (Choice) loop
+
+ -- If we find a matching choice, then the Expression of this
+ -- alternative replaces N (Raises_Constraint_Error flag is
+ -- included, so we don't have to special case that).
+
+ if Choice_Matches (Expression (N), Choice) = Match then
+ Rewrite (N, Relocate_Node (Expression (Alt)));
+ return;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ Next (Alt);
+ end loop Search;
end if;
end Eval_Case_Expression;
Is_Static_Expression (Then_Expr)
and then
Is_Static_Expression (Else_Expr);
+ -- True if result is static
begin
+ -- If result not static, nothing to do, otherwise set static result
+
+ if not Rstat then
+ return;
+ else
+ Set_Is_Static_Expression (N);
+ end if;
+
-- If any operand is Any_Type, just propagate to result and do not try
-- to fold, this prevents cascaded errors.
Set_Etype (N, Any_Type);
Set_Is_Static_Expression (N, False);
return;
+ end if;
+
+ -- If condition raises constraint error then we have already signalled
+ -- an error, and we just propagate to the result and do not fold.
+
+ if Raises_Constraint_Error (Condition) then
+ Set_Raises_Constraint_Error (N);
+ return;
+ end if;
-- Static case where we can fold. Note that we don't try to fold cases
-- where the condition is known at compile time, but the result is
-- the expander puts in a redundant test and we remove it. Instead we
-- deal with these cases in the expander.
- elsif Rstat then
+ -- Select result operand
- -- Select result operand
-
- if Is_True (Expr_Value (Condition)) then
- Result := Then_Expr;
- Non_Result := Else_Expr;
- else
- Result := Else_Expr;
- Non_Result := Then_Expr;
- end if;
+ if Is_True (Expr_Value (Condition)) then
+ Result := Then_Expr;
+ Non_Result := Else_Expr;
+ else
+ Result := Else_Expr;
+ Non_Result := Then_Expr;
+ 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 propagate Raises_Constraint_Error since this flag is
- -- set in Result.
+ -- 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
+ -- propagate Raises_Constraint_Error since this flag is set in Result.
- if Raises_Constraint_Error (Result) then
- Rewrite_In_Raise_CE (N, Result);
- Check_Non_Static_Context (Non_Result);
+ if Raises_Constraint_Error (Result) then
+ Rewrite_In_Raise_CE (N, Result);
+ Check_Non_Static_Context (Non_Result);
- -- Otherwise the result operand replaces the original node
-
- else
- Rewrite (N, Relocate_Node (Result));
- end if;
-
- -- Case of condition not known at compile time
+ -- Otherwise the result operand replaces the original node
else
- Check_Non_Static_Context (Condition);
- Check_Non_Static_Context (Then_Expr);
- Check_Non_Static_Context (Else_Expr);
+ Rewrite (N, Relocate_Node (Result));
+ Set_Is_Static_Expression (N);
end if;
-
- Set_Is_Static_Expression (N, Rstat);
end Eval_If_Expression;
----------------------------
procedure Eval_Membership_Op (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
- Def_Id : Entity_Id;
- Lo : Node_Id;
- Hi : Node_Id;
- Result : Boolean;
- Stat : Boolean;
- Fold : Boolean;
+ Alts : constant List_Id := Alternatives (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 Etype (Right) = Any_Type then
+ if Etype (Left) = Any_Type
+ or else (Present (Right) and then Etype (Right) = 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 (Predicate_Function (Etype (Right)))
+ or else (Present (Right)
+ and then Present (Predicate_Function (Etype (Right))))
then
return;
end if;
- -- Case of right operand is a subtype name
-
- if Is_Entity_Name (Right) then
- Def_Id := Entity (Right);
+ -- If left operand non-static, then nothing to do
- if (Is_Scalar_Type (Def_Id) or else Is_String_Type (Def_Id))
- and then Is_OK_Static_Subtype (Def_Id)
- then
- Test_Expression_Is_Foldable (N, Left, Stat, Fold);
+ if not Is_Static_Expression (Left) then
+ return;
+ end if;
- if not Fold or else not Stat then
- return;
- end if;
- else
- Check_Non_Static_Context (Left);
- return;
- end if;
+ -- If choice is non-static, left operand is in non-static context
- -- For string membership tests we will check the length further on
+ if (Present (Right) and then not Is_Static_Choice (Right))
+ or else (Present (Alts) and then not Is_Static_Choice_List (Alts))
+ then
+ Check_Non_Static_Context (Left);
+ return;
+ end if;
- if not Is_String_Type (Def_Id) then
- Lo := Type_Low_Bound (Def_Id);
- Hi := Type_High_Bound (Def_Id);
- else
- Lo := Empty;
- Hi := Empty;
- end if;
+ -- Otherwise we definitely have a static expression
- -- Case of right operand is a range
+ Set_Is_Static_Expression (N);
- else
- if Is_Static_Range (Right) then
- Test_Expression_Is_Foldable (N, Left, Stat, Fold);
+ -- If left operand raises constraint error, propagate and we are done
- if not Fold or else not Stat then
- return;
+ if Raises_Constraint_Error (Left) then
+ Set_Raises_Constraint_Error (N, True);
- -- If one bound of range raises CE, then don't try to fold
-
- elsif not Is_OK_Static_Range (Right) then
- Check_Non_Static_Context (Left);
- return;
- end if;
+ -- See if we match
+ else
+ if Present (Right) then
+ Result := Choice_Matches (Left, Right);
else
- Check_Non_Static_Context (Left);
- return;
+ Result := Choices_Match (Left, Alts);
end if;
- -- Here we know range is an OK static range
+ -- If result is Non_Static, it means that we raise Constraint_Error,
+ -- since we already tested that the operands were themselves static.
- Lo := Low_Bound (Right);
- Hi := High_Bound (Right);
- end if;
-
- -- For strings we check that the length of the string expression is
- -- compatible with the string subtype if the subtype is constrained,
- -- or if unconstrained then the test is always true.
+ if Result = Non_Static then
+ Set_Raises_Constraint_Error (N);
- if Is_String_Type (Etype (Right)) then
- if not Is_Constrained (Etype (Right)) then
- Result := True;
+ -- Otherwise we have our result (flipped if NOT IN case)
else
- declare
- Typlen : constant Uint := String_Type_Len (Etype (Right));
- Strlen : constant Uint :=
- UI_From_Int
- (String_Length (Strval (Get_String_Val (Left))));
- begin
- Result := (Typlen = Strlen);
- end;
+ Fold_Uint
+ (N, Test ((Result = Match) xor (Nkind (N) = N_Not_In)), True);
+ Warn_On_Known_Condition (N);
end if;
-
- -- Fold the membership test. We know we have a static range and Lo and
- -- Hi are set to the expressions for the end points of this range.
-
- elsif Is_Real_Type (Etype (Right)) then
- declare
- Leftval : constant Ureal := Expr_Value_R (Left);
- begin
- Result := Expr_Value_R (Lo) <= Leftval
- and then Leftval <= Expr_Value_R (Hi);
- end;
-
- else
- declare
- Leftval : constant Uint := Expr_Value (Left);
- begin
- Result := Expr_Value (Lo) <= Leftval
- and then Leftval <= Expr_Value (Hi);
- end;
- end if;
-
- if Nkind (N) = N_Not_In then
- Result := not Result;
end if;
-
- Fold_Uint (N, Test (Result), True);
-
- Warn_On_Known_Condition (N);
end Eval_Membership_Op;
------------------------
end if;
end Eval_Slice;
- ---------------------------------
- -- Eval_Static_Predicate_Check --
- ---------------------------------
-
- function Eval_Static_Predicate_Check
- (N : Node_Id;
- Typ : Entity_Id) return Boolean
- is
- Loc : constant Source_Ptr := Sloc (N);
-
- begin
- -- Discrete type case
-
- if Is_Discrete_Type (Typ) then
- declare
- Pred : constant List_Id := Static_Predicate (Typ);
- Test : Node_Id;
-
- begin
- pragma Assert (Present (Pred));
-
- -- The static predicate is a list of alternatives in the proper
- -- format for an Ada 2012 membership test. If the argument is a
- -- literal, the membership test can be evaluated statically. This
- -- is easier than running a full intepretation of the predicate
- -- expression, and more efficient in some cases.
-
- Test :=
- Make_In (Loc,
- Left_Opnd => New_Copy_Tree (N),
- Right_Opnd => Empty,
- Alternatives => Pred);
- Analyze_And_Resolve (Test, Standard_Boolean);
-
- return Nkind (Test) = N_Identifier
- and then Entity (Test) = Standard_True;
- end;
-
- -- Real type case
-
- else
- pragma Assert (Is_Real_Type (Typ));
- Error_Msg_N ("??real predicate not applied", N);
- return True;
- end if;
- end Eval_Static_Predicate_Check;
-
-------------------------
-- Eval_String_Literal --
-------------------------
Typ : constant Entity_Id := Etype (N);
begin
+ if Raises_Constraint_Error (N) then
+ Set_Is_Static_Expression (N, Static);
+ return;
+ end if;
+
Rewrite (N, Make_String_Literal (Loc, Strval => Val));
-- We now have the literal with the right value, both the actual type
Ent : Entity_Id;
begin
+ if Raises_Constraint_Error (N) then
+ Set_Is_Static_Expression (N, Static);
+ return;
+ end if;
+
-- If we are folding a named number, retain the entity in the literal,
-- for ASIS use.
Ent : Entity_Id;
begin
+ if Raises_Constraint_Error (N) then
+ Set_Is_Static_Expression (N, Static);
+ return;
+ end if;
+
-- If we are folding a named number, retain the entity in the literal,
-- for ASIS use.
end if;
end Is_Null_Range;
+ -------------------------
+ -- Is_OK_Static_Choice --
+ -------------------------
+
+ function Is_OK_Static_Choice (Choice : Node_Id) return Boolean is
+ begin
+ -- Check various possibilities for choice
+
+ -- Note: for membership tests, we test more cases than are possible
+ -- (in particular subtype indication), but it doesn't matter because
+ -- it just won't occur (we have already done a syntax check).
+
+ if Nkind (Choice) = N_Others_Choice then
+ return True;
+
+ elsif Nkind (Choice) = N_Range then
+ return Is_OK_Static_Range (Choice);
+
+ elsif Nkind (Choice) = N_Subtype_Indication
+ or else
+ (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
+ then
+ return Is_OK_Static_Subtype (Etype (Choice));
+
+ else
+ return Is_OK_Static_Expression (Choice);
+ end if;
+ end Is_OK_Static_Choice;
+
+ ------------------------------
+ -- Is_OK_Static_Choice_List --
+ ------------------------------
+
+ function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean is
+ Choice : Node_Id;
+
+ begin
+ if not Is_Static_Choice_List (Choices) then
+ return False;
+ end if;
+
+ Choice := First (Choices);
+ while Present (Choice) loop
+ if not Is_OK_Static_Choice (Choice) then
+ Set_Raises_Constraint_Error (Choice);
+ return False;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ return True;
+ end Is_OK_Static_Choice_List;
+
-----------------------------
-- Is_OK_Static_Expression --
-----------------------------
Out_Of_Range;
end Is_Out_Of_Range;
- ---------------------
+ ----------------------
+ -- Is_Static_Choice --
+ ----------------------
+
+ function Is_Static_Choice (Choice : Node_Id) return Boolean is
+ begin
+ -- Check various possibilities for choice
+
+ -- Note: for membership tests, we test more cases than are possible
+ -- (in particular subtype indication), but it doesn't matter because
+ -- it just won't occur (we have already done a syntax check).
+
+ if Nkind (Choice) = N_Others_Choice then
+ return True;
+
+ elsif Nkind (Choice) = N_Range then
+ return Is_Static_Range (Choice);
+
+ elsif Nkind (Choice) = N_Subtype_Indication
+ or else
+ (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
+ then
+ return Is_Static_Subtype (Etype (Choice));
+
+ else
+ return Is_Static_Expression (Choice);
+ end if;
+ end Is_Static_Choice;
+
+ ---------------------------
+ -- Is_Static_Choice_List --
+ ---------------------------
+
+ function Is_Static_Choice_List (Choices : List_Id) return Boolean is
+ Choice : Node_Id;
+
+ begin
+ Choice := First (Choices);
+ while Present (Choice) loop
+ if not Is_Static_Choice (Choice) then
+ return False;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ return True;
+ end Is_Static_Choice_List;
+
+---------------------
-- Is_Static_Range --
---------------------
function Is_Static_Range (N : Node_Id) return Boolean is
begin
- return Is_Static_Expression (Low_Bound (N))
+ return Is_Static_Expression (Low_Bound (N))
and then
Is_Static_Expression (High_Bound (N));
end Is_Static_Range;
end if;
end Is_Static_Subtype;
+ -------------------------------
+ -- Is_Statically_Unevaluated --
+ -------------------------------
+
+ function Is_Statically_Unevaluated (Expr : Node_Id) return Boolean is
+ function Check_Case_Expr_Alternative
+ (CEA : Node_Id) return Match_Result;
+ -- We have a message emanating from the Expression of a case expression
+ -- alternative. We examine this alternative, as follows:
+ --
+ -- If the selecting expression of the parent case is non-static, or
+ -- if any of the discrete choices of the given case alternative are
+ -- non-static or raise Constraint_Error, return Non_Static.
+ --
+ -- Otherwise check if the selecting expression matches any of the given
+ -- discrete choices. If so the alternative is executed and we return
+ -- Open, otherwise, the alternative can never be executed, and so we
+ -- return Closed.
+
+ ---------------------------------
+ -- Check_Case_Expr_Alternative --
+ ---------------------------------
+
+ function Check_Case_Expr_Alternative
+ (CEA : Node_Id) return Match_Result
+ is
+ Case_Exp : constant Node_Id := Parent (CEA);
+ Choice : Node_Id;
+ Prev_CEA : Node_Id;
+
+ begin
+ pragma Assert (Nkind (Case_Exp) = N_Case_Expression);
+
+ -- Check selecting expression is static
+
+ if not Is_OK_Static_Expression (Expression (Case_Exp)) then
+ return Non_Static;
+ end if;
+
+ if not Is_OK_Static_Choice_List (Discrete_Choices (CEA)) then
+ return Non_Static;
+ end if;
+
+ -- All choices are now known to be static. Now see if alternative
+ -- matches one of the choices.
+
+ Choice := First (Discrete_Choices (CEA));
+ while Present (Choice) loop
+
+ -- Check various possibilities for choice, returning Closed if we
+ -- find the selecting value matches any of the choices. Note that
+ -- we know we are the last choice, so we don't have to keep going.
+
+ if Nkind (Choice) = N_Others_Choice then
+
+ -- Others choice is a bit annoying, it matches if none of the
+ -- previous alternatives matches (note that we know we are the
+ -- last alternative in this case, so we can just go backwards
+ -- from us to see if any previous one matches).
+
+ Prev_CEA := Prev (CEA);
+ while Present (Prev_CEA) loop
+ if Check_Case_Expr_Alternative (Prev_CEA) = Match then
+ return No_Match;
+ end if;
+
+ Prev (Prev_CEA);
+ end loop;
+
+ return Match;
+
+ -- Else we have a normal static choice
+
+ elsif Choice_Matches (Expression (Case_Exp), Choice) = Match then
+ return Match;
+ end if;
+
+ -- If we fall through, it means that the discrete choice did not
+ -- match the selecting expression, so continue.
+
+ Next (Choice);
+ end loop;
+
+ -- If we get through that loop then all choices were static, and
+ -- none of them matched the selecting expression. So return Closed.
+
+ return No_Match;
+ end Check_Case_Expr_Alternative;
+
+ -- Local variables
+
+ P : Node_Id;
+ OldP : Node_Id;
+ Choice : Node_Id;
+
+ -- Start of processing for Is_Statically_Unevaluated
+
+ begin
+ -- The (32.x) references here are from RM section 4.9
+
+ -- (32.1) An expression is statically unevaluated if it is part of ...
+
+ -- This means we have to climb the tree looking for one of the cases
+
+ P := Expr;
+ loop
+ OldP := P;
+ P := Parent (P);
+
+ -- (32.2) The right operand of a static short-circuit control form
+ -- whose value is determined by its left operand.
+
+ -- AND THEN with False as left operand
+
+ if Nkind (P) = N_And_Then
+ and then Compile_Time_Known_Value (Left_Opnd (P))
+ and then Is_False (Expr_Value (Left_Opnd (P)))
+ then
+ return True;
+
+ -- OR ELSE with True as left operand
+
+ elsif Nkind (P) = N_Or_Else
+ and then Compile_Time_Known_Value (Left_Opnd (P))
+ and then Is_True (Expr_Value (Left_Opnd (P)))
+ then
+ return True;
+
+ -- (32.3) A dependent_expression of an if_expression whose associated
+ -- condition is static and equals False.
+
+ elsif Nkind (P) = N_If_Expression then
+ declare
+ Cond : constant Node_Id := First (Expressions (P));
+ Texp : constant Node_Id := Next (Cond);
+ Fexp : constant Node_Id := Next (Texp);
+
+ begin
+ if Compile_Time_Known_Value (Cond) then
+
+ -- Condition is True and we are in the right operand
+
+ if Is_True (Expr_Value (Cond)) and then OldP = Fexp then
+ return True;
+
+ -- Condition is False and we are in the left operand
+
+ elsif Is_False (Expr_Value (Cond)) and then OldP = Texp then
+ return True;
+ end if;
+ end if;
+ end;
+
+ -- (32.4) A condition or dependent_expression of an if_expression
+ -- where the condition corresponding to at least one preceding
+ -- dependent_expression of the if_expression is static and equals
+ -- True.
+
+ -- This refers to cases like
+
+ -- (if 1 then 1 elsif 1/0=2 then 2 else 3)
+
+ -- But we expand elsif's out anyway, so the above looks like:
+
+ -- (if 1 then 1 else (if 1/0=2 then 2 else 3))
+
+ -- So for us this is caught by the above check for the 32.3 case.
+
+ -- (32.5) A dependent_expression of a case_expression whose
+ -- selecting_expression is static and whose value is not covered
+ -- by the corresponding discrete_choice_list.
+
+ elsif Nkind (P) = N_Case_Expression_Alternative then
+
+ -- First, we have to be in the expression to suppress messages.
+ -- If we are within one of the choices, we want the message.
+
+ if OldP = Expression (P) then
+
+ -- Statically unevaluated if alternative does not match
+
+ if Check_Case_Expr_Alternative (P) = No_Match then
+ return True;
+ end if;
+ end if;
+
+ -- (32.6) A choice_expression (or a simple_expression of a range
+ -- that occurs as a membership_choice of a membership_choice_list)
+ -- of a static membership test that is preceded in the enclosing
+ -- membership_choice_list by another item whose individual
+ -- membership test (see (RM 4.5.2)) statically yields True.
+
+ elsif Nkind (P) in N_Membership_Test then
+
+ -- Only possibly unevaluated if simple expression is static
+
+ if not Is_OK_Static_Expression (Left_Opnd (P)) then
+ null;
+
+ -- All members of the choice list must be static
+
+ elsif (Present (Right_Opnd (P))
+ and then not Is_OK_Static_Choice (Right_Opnd (P)))
+ or else (Present (Alternatives (P))
+ and then
+ not Is_OK_Static_Choice_List (Alternatives (P)))
+ then
+ null;
+
+ -- If expression is the one and only alternative, then it is
+ -- definitely not statically unevaluated, so we only have to
+ -- test the case where there are alternatives present.
+
+ elsif Present (Alternatives (P)) then
+
+ -- Look for previous matching Choice
+
+ Choice := First (Alternatives (P));
+ while Present (Choice) loop
+
+ -- If we reached us and no previous choices matched, this
+ -- is not the case where we are statically unevaluated.
+
+ exit when OldP = Choice;
+
+ -- If a previous choice matches, then that is the case where
+ -- we know our choice is statically unevaluated.
+
+ if Choice_Matches (Left_Opnd (P), Choice) = Match then
+ return True;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ -- If we fall through the loop, we were not one of the choices,
+ -- we must have been the expression, so that is not covered by
+ -- this rule, and we keep going.
+
+ null;
+ end if;
+ end if;
+
+ -- OK, not statically unevaluated at this level, see if we should
+ -- keep climbing to look for a higher level reason.
+
+ -- Special case for component association in aggregates, where
+ -- we want to keep climbing up to the parent aggregate.
+
+ if Nkind (P) = N_Component_Association
+ and then Nkind (Parent (P)) = N_Aggregate
+ then
+ null;
+
+ -- All done if not still within subexpression
+
+ else
+ exit when Nkind (P) not in N_Subexpr;
+ end if;
+ end loop;
+
+ -- If we fall through the loop, not one of the cases covered!
+
+ return False;
+ end Is_Statically_Unevaluated;
+
--------------------
-- Not_Null_Range --
--------------------
-------------------------
procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
- Typ : constant Entity_Id := Etype (N);
+ Typ : constant Entity_Id := Etype (N);
+ Stat : constant Boolean := Is_Static_Expression (N);
begin
- -- If we want to raise CE in the condition of a N_Raise_CE node
- -- we may as well get rid of the condition.
+ -- If we want to raise CE in the condition of a N_Raise_CE node, we
+ -- can just clear the condition if the reason is appropriate. We do
+ -- not do this operation if the parent has a reason other than range
+ -- check failed, because otherwise we would change the reason.
if Present (Parent (N))
and then Nkind (Parent (N)) = N_Raise_Constraint_Error
+ and then Reason (Parent (N)) =
+ UI_From_Int (RT_Exception_Code'Pos (CE_Range_Check_Failed))
then
Set_Condition (Parent (N), Empty);
Rewrite (N, Exp);
Set_Etype (N, Typ);
- -- Else build an explcit N_Raise_CE
+ -- Else build an explicit N_Raise_CE
else
Rewrite (N,
Set_Raises_Constraint_Error (N);
Set_Etype (N, Typ);
end if;
+
+ -- Set proper flags in result
+
+ Set_Raises_Constraint_Error (N, True);
+ Set_Is_Static_Expression (N, Stat);
end Rewrite_In_Raise_CE;
---------------------
-- If either subtype is nonstatic then they're not compatible
- elsif not Is_Static_Subtype (T1)
+ elsif not Is_OK_Static_Subtype (T1)
or else
- not Is_Static_Subtype (T2)
+ not Is_OK_Static_Subtype (T2)
then
return False;
-- Otherwise bounds must be static and identical value
else
- if not Is_Static_Subtype (T1)
- or else not Is_Static_Subtype (T2)
+ if not Is_OK_Static_Subtype (T1)
+ or else not Is_OK_Static_Subtype (T2)
then
return False;
Expr2 : constant Node_Id := Node (DA2);
begin
- if not Is_Static_Expression (Expr1)
- or else not Is_Static_Expression (Expr2)
+ if not Is_OK_Static_Expression (Expr1)
+ or else not Is_OK_Static_Expression (Expr2)
then
return False;
N : constant Node_Id := Original_Node (Expr);
Typ : Entity_Id;
E : Entity_Id;
+ Alt : Node_Id;
+ Exp : Node_Id;
procedure Why_Not_Static_List (L : List_Id);
-- A version that can be called on a list of expressions. Finds all
-- Test for constraint error raised
if Raises_Constraint_Error (Expr) then
+
+ -- Special case membership to find out which piece to flag
+
+ if Nkind (N) in N_Membership_Test then
+ if Raises_Constraint_Error (Left_Opnd (N)) then
+ Why_Not_Static (Left_Opnd (N));
+ return;
+
+ elsif Present (Right_Opnd (N))
+ and then Raises_Constraint_Error (Right_Opnd (N))
+ then
+ Why_Not_Static (Right_Opnd (N));
+ return;
+
+ else
+ pragma Assert (Present (Alternatives (N)));
+
+ Alt := First (Alternatives (N));
+ while Present (Alt) loop
+ if Raises_Constraint_Error (Alt) then
+ Why_Not_Static (Alt);
+ return;
+ else
+ Next (Alt);
+ end if;
+ end loop;
+ end if;
+
+ -- Special case a range to find out which bound to flag
+
+ elsif Nkind (N) = N_Range then
+ if Raises_Constraint_Error (Low_Bound (N)) then
+ Why_Not_Static (Low_Bound (N));
+ return;
+
+ elsif Raises_Constraint_Error (High_Bound (N)) then
+ Why_Not_Static (High_Bound (N));
+ return;
+ end if;
+
+ -- Special case attribute to see which part to flag
+
+ elsif Nkind (N) = N_Attribute_Reference then
+ if Raises_Constraint_Error (Prefix (N)) then
+ Why_Not_Static (Prefix (N));
+ return;
+ end if;
+
+ if Present (Expressions (N)) then
+ Exp := First (Expressions (N));
+ while Present (Exp) loop
+ if Raises_Constraint_Error (Exp) then
+ Why_Not_Static (Exp);
+ return;
+ end if;
+
+ Next (Exp);
+ end loop;
+ end if;
+
+ -- Special case a subtype name
+
+ elsif Is_Entity_Name (Expr) and then Is_Type (Entity (Expr)) then
+ Error_Msg_NE
+ ("!& is not a static subtype (RM 4.9(26))", N, Entity (Expr));
+ return;
+ end if;
+
+ -- End of special cases
+
Error_Msg_N
("!expression raises exception, cannot be static (RM 4.9(34))",
N);
end if;
end Entity_Case;
+ elsif Is_Type (E) then
+ Error_Msg_NE
+ ("!& is not a static subtype (RM 4.9(26))", N, E);
+
else
Error_Msg_NE
("!& is not static constant or named number "
("!attribute of generic type is never static "
& "(RM 4.9(7,8))", N);
- elsif Is_Static_Subtype (E) then
+ elsif Is_OK_Static_Subtype (E) then
null;
elsif Is_Scalar_Type (E) then
Why_Not_Static (Expression (N));
if not Is_Scalar_Type (Entity (Subtype_Mark (N)))
- or else not Is_Static_Subtype (Entity (Subtype_Mark (N)))
+ or else not Is_OK_Static_Subtype (Entity (Subtype_Mark (N)))
then
Error_Msg_N
("!static conversion requires static scalar subtype result "
-- (i.e. the flag is accurate for static expressions, and conservative
-- for non-static expressions.
- -- If a static expression does not raise constraint error, then the
- -- Raises_Constraint_Error flag is off, and the expression must be computed
- -- at compile time, which means that it has the form of either a literal,
- -- or a constant that is itself (recursively) either a literal or a
- -- constant.
+ -- If a static expression does not raise constraint error, then it will
+ -- have the flag Raises_Constraint_Error flag False, and the expression
+ -- must be computed at compile time, which means that it has the form of
+ -- either a literal, or a constant that is itself (recursively) either a
+ -- literal or a constant.
-- The above rules must be followed exactly in order for legality checks to
-- be accurate. For subexpressions that are not static according to the RM
-- definition, they are sometimes folded anyway, but of course in this case
-- Is_Static_Expression is not set.
+ -- When we are analyzing and evaluating static expressions, we proopagate
+ -- both flags accurately. Usually if a subexpression raises a constraint
+ -- error, then so will its parent expression, and Raise_Constraint_Error
+ -- will be propagated to this parent. The exception is conditional cases
+ -- like (True or else 1/0 = 0) which results in an expresion that has the
+ -- Is_Static_Expression flag True, and Raises_Constraint_Error False. Even
+ -- though 1/0 would raise an exception, the right operand is never actually
+ -- executed, so the expression as a whole does not raise CE.
+
+ -- For constructs in the language where static expressions are part of the
+ -- required semantics, we need an expression that meets the 4.9 rules and
+ -- does not raise CE. So nearly everywhere, callers should call function
+ -- Is_OK_Static_Expression rather than Is_Static_Expression.
+
+ -- Finally, the case of static predicates. These are applied only to entire
+ -- expressions, not to subexpressions, so we do not have the case of having
+ -- to propagate this information. We handle this case simply by resetting
+ -- the Is_Static_Expression flag if a static predicate fails. Note that we
+ -- can't use this simpler approach for the constraint error case because of
+ -- the (True or else 1/0 = 0) example discussed above.
+
-------------------------------
-- Compile-Time Known Values --
-------------------------------
-- Subprograms --
-----------------
+ procedure Check_Expression_Against_Static_Predicate
+ (Expr : Node_Id;
+ Typ : Entity_Id);
+ -- Determine whether an arbitrary expression satisfies the static predicate
+ -- of a type. The routine does nothing if Expr is not known at compile time
+ -- or Typ lacks a static predicate, otherwise it may emit a warning if the
+ -- expression is prohibited by the predicate. If the expression is a static
+ -- expression and it fails a predicate that was not explicitly stated to be
+ -- a dynamic predicate, then an additional warning is given, and the flag
+ -- Is_Static_Expression is reset on Expr.
+
procedure Check_Non_Static_Context (N : Node_Id);
-- Deals with the special check required for a static expression that
-- appears in a non-static context, i.e. is not part of a larger static
-- for compile time evaluation purposes. Use Compile_Time_Known_Value
-- instead (see section on "Compile-Time Known Values" above).
- 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
- -- equivalent range attribute references already turned them into the
- -- equivalent range).
-
function Is_OK_Static_Range (N : Node_Id) return Boolean;
- -- Like Is_Static_Range, but also makes sure that the bounds of the range
- -- are compile-time evaluable (i.e. do not raise constraint error). A
- -- result of true means that the bounds are compile time evaluable. A
- -- result of false means they are not (either because the range is not
- -- static, or because one or the other bound raises CE).
+ -- Determines if range is static, as defined in RM 4.9(26), and also checks
+ -- that neither bound of the range raises constraint error, thus ensuring
+ -- that both bounds of the range are compile-time evaluable (i.e. do not
+ -- raise constraint error). A result of true means that the bounds are
+ -- compile time evaluable. A result of false means they are not (either
+ -- because the range is not static, or because one or the other bound
+ -- raises CE).
function Is_Static_Subtype (Typ : Entity_Id) return Boolean;
-- Determines whether a subtype fits the definition of an Ada static
-- Implementation note: an attempt to include this Ada 2012 case failed,
-- since it appears that this routine is called in some cases before the
-- Static_Predicate field is set ???
+ --
+ -- This differs from Is_OK_Static_Subtype (which is what must be used by
+ -- clients) in that it does not care whether the bounds raise a constraint
+ -- error exception or not. Used for checking whether expressions are static
+ -- in the 4.9 sense (without worrying about exceptions).
function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean;
- -- Like Is_Static_Subtype but also makes sure that the bounds of the
- -- subtype are compile-time evaluable (i.e. do not raise constraint error).
- -- A result of true means that the bounds are compile time evaluable. A
- -- result of false means they are not (either because the range is not
- -- static, or because one or the other bound raises CE).
+ -- Determines whether a subtype fits the definition of an Ada static
+ -- subtype as given in (RM 4.9(26)) with the additional check that neither
+ -- bound raises constraint error (meaning that Expr_Value[_R|S] can be used
+ -- on these bounds. Important note: This check does not include the Ada
+ -- 2012 case of a non-static predicate which results in an otherwise static
+ -- subtype being non-static. Such a subtype will return True for this test,
+ -- so if the distinction is important, the caller must deal with this.
+ --
+ -- Implementation note: an attempt to include this Ada 2012 case failed,
+ -- since it appears that this routine is called in some cases before the
+ -- Static_Predicate field is set ???
+ --
+ -- This differs from Is_Static_Subtype in that it includes the constraint
+ -- error checks, which are missing from Is_Static_Subtype.
function Subtypes_Statically_Compatible
(T1 : Entity_Id;
procedure Eval_Unary_Op (N : Node_Id);
procedure Eval_Unchecked_Conversion (N : Node_Id);
- function Eval_Static_Predicate_Check
- (N : Node_Id;
- Typ : Entity_Id) return Boolean;
- -- Evaluate a static predicate check applied expression which represents
- -- a value that is known at compile time (does not have to be static). The
- -- caller has checked that a static predicate does apply to Typ, and thus
- -- the type is known to be scalar.
-
procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean);
-- Rewrite N with a new N_String_Literal node as the result of the compile
-- time evaluation of the node N. Val is the resulting string value from
-- static). The point here is that normally all string literals are static,
-- but if this was the result of some sequence of evaluation where values
-- were known at compile time but not static, then the result is not
- -- static.
+ -- static. The call has no effect if Raises_Constraint_Error (N) is True,
+ -- since there is no point in folding if we have an error.
procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean);
-- Rewrite N with a (N_Integer_Literal, N_Identifier, N_Character_Literal)
-- consider static). The point here is that normally all integer literals
-- are static, but if this was the result of some sequence of evaluation
-- where values were known at compile time but not static, then the result
- -- is not static.
+ -- is not static. The call has no effect if Raises_Constraint_Error (N) is
+ -- True, since there is no point in folding if we have an error.
procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean);
-- Rewrite N with a new N_Real_Literal node as the result of the compile
-- The point here is that normally all string literals are static, but if
-- this was the result of some sequence of evaluation where values were
-- known at compile time but not static, then the result is not static.
+ -- The call has no effect if Raises_Constraint_Error (N) is True, since
+ -- there is no point in folding if we have an error.
function Is_In_Range
(N : Node_Id;
-- cannot (because the value of Lo or Hi is not known at compile time) then
-- it returns False.
+ function Is_Statically_Unevaluated (Expr : Node_Id) return Boolean;
+ -- This function returns True if the given expression Expr is statically
+ -- unevaluated, as defined in (RM 4.9 (32.1-32.6)).
+
function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean;
-- Returns True if it can guarantee that Lo .. Hi is not a null range. If
-- it cannot (because the value of Lo or Hi is not known at compile time)
--
-- Note that these messages are not continuation messages, instead they are
-- separate unconditional messages, marked with '!'. The reason for this is
- -- that they can be posted at a different location from the maim message as
+ -- that they can be posted at a different location from the main message as
-- documented above ("appropriate offending component"), and continuation
-- messages must always point to the same location as the parent message.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2014, 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- --
null;
elsif Nkind (Arg1) /= N_String_Literal
- and then not Is_Static_Expression (Arg1)
+ and then not Is_OK_Static_Expression (Arg1)
then
Error_Msg_FE
("call to & requires static string argument!", N, Nam);
if Present (Expr) then
Analyze_And_Resolve (Expr, Standard_Boolean);
- if Is_Static_Expression (Expr) then
+ if Is_OK_Static_Expression (Expr) then
Expr_Val := Is_True (Expr_Value (Expr));
else
Error_Msg_Name_1 := Pragma_Name (N);
-- Check the specified argument Arg to make sure that it is a valid
-- queuing policy name. If not give error and raise Pragma_Exit.
- procedure Check_Arg_Is_Static_Expression
+ procedure Check_Arg_Is_OK_Static_Expression
(Arg : Node_Id;
Typ : Entity_Id := Empty);
-- Check the specified argument Arg to make sure that it is a static
-- expression of the given type (i.e. it will be analyzed and resolved
-- using this type, which can be any valid argument to Resolve, e.g.
-- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
- -- Typ is left Empty, then any static expression is allowed.
+ -- Typ is left Empty, then any static expression is allowed. Includes
+ -- checking that the argument does not raise Constraint_Error.
procedure Check_Arg_Is_Task_Dispatching_Policy (Arg : Node_Id);
-- Check the specified argument Arg to make sure that it is a valid task
-- This procedure checks for possible duplications if this is the export
-- case, and if found, issues an appropriate error message.
- procedure Check_Expr_Is_Static_Expression
+ procedure Check_Expr_Is_OK_Static_Expression
(Expr : Node_Id;
Typ : Entity_Id := Empty);
-- Check the specified expression Expr to make sure that it is a static
-- expression of the given type (i.e. it will be analyzed and resolved
-- using this type, which can be any valid argument to Resolve, e.g.
-- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
- -- Typ is left Empty, then any static expression is allowed.
+ -- Typ is left Empty, then any static expression is allowed. Includes
+ -- checking that the expression does not raise Constraint_Error.
procedure Check_First_Subtype (Arg : Node_Id);
-- Checks that Arg, whose expression is an entity name, references a
-- Static expression that raises Constraint_Error. This has
-- already been flagged, so just exit from pragma processing.
- elsif Is_Static_Expression (Argx) then
+ elsif Is_OK_Static_Expression (Argx) then
raise Pragma_Exit;
-- Here we have a real error (non-static expression)
end if;
end Check_Arg_Is_Queuing_Policy;
- ------------------------------------
- -- Check_Arg_Is_Static_Expression --
- ------------------------------------
+ ---------------------------------------
+ -- Check_Arg_Is_OK_Static_Expression --
+ ---------------------------------------
- procedure Check_Arg_Is_Static_Expression
+ procedure Check_Arg_Is_OK_Static_Expression
(Arg : Node_Id;
Typ : Entity_Id := Empty)
is
begin
- Check_Expr_Is_Static_Expression (Get_Pragma_Arg (Arg), Typ);
- end Check_Arg_Is_Static_Expression;
+ Check_Expr_Is_OK_Static_Expression (Get_Pragma_Arg (Arg), Typ);
+ end Check_Arg_Is_OK_Static_Expression;
------------------------------------------
-- Check_Arg_Is_Task_Dispatching_Policy --
end if;
end Check_Duplicated_Export_Name;
- -------------------------------------
- -- Check_Expr_Is_Static_Expression --
- -------------------------------------
+ ----------------------------------------
+ -- Check_Expr_Is_OK_Static_Expression --
+ ----------------------------------------
- procedure Check_Expr_Is_Static_Expression
+ procedure Check_Expr_Is_OK_Static_Expression
(Expr : Node_Id;
Typ : Entity_Id := Empty)
is
-- Static expression that raises Constraint_Error. This has already
-- been flagged, so just exit from pragma processing.
- elsif Is_Static_Expression (Expr) then
+ elsif Is_OK_Static_Expression (Expr) then
raise Pragma_Exit;
-- Finally, we have a real error
Expr);
raise Pragma_Exit;
end if;
- end Check_Expr_Is_Static_Expression;
+ end Check_Expr_Is_OK_Static_Expression;
-------------------------
-- Check_First_Subtype --
((Name_Name, Name_Mode, Name_Requires, Name_Ensures));
Check_Optional_Identifier (Arg1, Name_Name);
- Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
-- In ASIS mode, for a pragma generated from a source aspect, also
-- analyze the original aspect expression.
if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
- Check_Expr_Is_Static_Expression
+ Check_Expr_Is_OK_Static_Expression
(Original_Node (Get_Pragma_Arg (Arg1)), Standard_String);
end if;
begin
Check_Arg_Count (2);
Check_No_Identifiers;
- Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
Analyze_And_Resolve (Arg1x, Standard_Boolean);
if Compile_Time_Known_Value (Arg1x) then
Arg_Code);
end if;
- Check_Arg_Is_Static_Expression (Arg_Code, Any_Integer);
+ Check_Arg_Is_OK_Static_Expression (Arg_Code, Any_Integer);
Code_Val := Expr_Value (Arg_Code);
if not UI_Is_In_Int_Range (Code_Val) then
else
-- As only a string is allowed, Check_Arg_Is_External_Name
-- isn't called.
- Check_Arg_Is_Static_Expression (Arg3, Standard_String);
+
+ Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
end if;
if Present (Arg4) then
elsif Nkind (Parent (Def_Id)) = N_Incomplete_Type_Declaration then
Check_No_Link_Name;
Check_Arg_Count (3);
- Check_Arg_Is_Static_Expression (Arg3, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
Process_Import_Predefined_Type;
-- Check expressions for external name and link name are static
if Present (Ext_Nam) then
- Check_Arg_Is_Static_Expression (Ext_Nam, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Ext_Nam, Standard_String);
Check_Form_Of_Interface_Name (Ext_Nam, Ext_Name_Case => True);
-- Verify that external name is not the name of a local entity,
end if;
if Present (Link_Nam) then
- Check_Arg_Is_Static_Expression (Link_Nam, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Link_Nam, Standard_String);
Check_Form_Of_Interface_Name (Link_Nam, Ext_Name_Case => False);
end if;
if Present (Expr) then
Analyze_And_Resolve (Expr, Standard_Boolean);
- if Is_Static_Expression (Expr) then
+ if Is_OK_Static_Expression (Expr) then
Expr_Val := Is_True (Expr_Value (Expr));
else
SPARK_Msg_N
Check_Optional_Identifier (Arg1, "max_size");
Arg := Get_Pragma_Arg (Arg1);
- Check_Arg_Is_Static_Expression (Arg, Any_Integer);
+ Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
Val := Expr_Value (Arg);
-- Must be static
- if not Is_Static_Expression (Arg) then
+ if not Is_OK_Static_Expression (Arg) then
Flag_Non_Static_Expr
("main subprogram affinity is not static!", Arg);
raise Pragma_Exit;
Check_Arg_Count (2);
Check_Optional_Identifier (Arg1, Name_Value);
- Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
+ Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
Check_Optional_Identifier (Arg2, Name_Link_Name);
- Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
-----------------------------
-- Export_Valued_Procedure --
GNAT_Pragma;
Check_Arg_Count (1);
Check_No_Identifiers;
- Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
Store_Note (N);
-- For pragma Ident, preserve DEC compatibility by requiring the
-- expression of type Ada.Interrupts.Interrupt_ID.
else
- Check_Arg_Is_Static_Expression (Arg1, Any_Integer);
+ Check_Arg_Is_OK_Static_Expression (Arg1, Any_Integer);
Int_Val := Expr_Value (Arg1X);
if Int_Val < Expr_Value (Type_Low_Bound (Int_Id))
if Arg_Count = 3 then
Check_Optional_Identifier (Arg3, Name_Message);
- Check_Arg_Is_Static_Expression (Arg3, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Arg3, Standard_String);
end if;
Check_Arg_Is_Local_Name (Arg1);
Check_At_Least_N_Arguments (1);
Check_No_Identifiers;
Check_Is_In_Decl_Part_Or_Package_Spec;
- Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
Start_String;
Arg := Arg1;
while Present (Arg) loop
- Check_Arg_Is_Static_Expression (Arg, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
-- Store argument, converting sequences of spaces to a
-- single null character (this is one of the differences
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Optional_Identifier (Arg2, Name_Target);
Check_Arg_Is_Library_Level_Local_Name (Arg1);
- Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
-- The only processing required is to link this item on to the
-- list of rep items for the given entity. This is accomplished
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Is_In_Decl_Part_Or_Package_Spec;
- Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
Start_String (Strval (Expr_Value_S (Get_Pragma_Arg (Arg1))));
Arg := Arg2;
while Present (Arg) loop
- Check_Arg_Is_Static_Expression (Arg, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Arg, Standard_String);
Store_String_Char (ASCII.NUL);
Store_String_Chars
(Strval (Expr_Value_S (Get_Pragma_Arg (Arg))));
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Optional_Identifier (Arg2, Name_Section);
Check_Arg_Is_Library_Level_Local_Name (Arg1);
- Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
-- Check kind of entity
if Arg_Count = 3 then
Check_Optional_Identifier (Arg3, Name_Info);
- Check_Arg_Is_Static_Expression (Arg3);
+ Check_Arg_Is_OK_Static_Expression (Arg3);
else
Check_Arg_Count (2);
end if;
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Optional_Identifier (Arg2, Name_Attribute_Name);
Check_Arg_Is_Local_Name (Arg1);
- Check_Arg_Is_Static_Expression (Arg2, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
Def_Id := Entity (Get_Pragma_Arg (Arg1));
if Is_Access_Type (Def_Id) then
for J in 1 .. 2 loop
if Present (Args (J)) then
- Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
+ Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
end if;
end loop;
if Present (Args (3)) then
- Check_Arg_Is_Static_Expression (Args (3), Standard_Boolean);
+ Check_Arg_Is_OK_Static_Expression (Args (3), Standard_Boolean);
end if;
Nod := Next (N);
for J in 1 .. 2 loop
if Present (Args (J)) then
- Check_Arg_Is_Static_Expression (Args (J), Any_Integer);
+ Check_Arg_Is_OK_Static_Expression (Args (J), Any_Integer);
end if;
end loop;
-- Deal with static string argument
- Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
S := Strval (Get_Pragma_Arg (Arg1));
for J in 1 .. String_Length (S) loop
-- Must be static
- if not Is_Static_Expression (Arg) then
+ if not Is_OK_Static_Expression (Arg) then
Flag_Non_Static_Expr
("main subprogram priority is not static!", Arg);
raise Pragma_Exit;
DP := Fold_Upper (Name_Buffer (1));
Lower_Bound := Get_Pragma_Arg (Arg2);
- Check_Arg_Is_Static_Expression (Lower_Bound, Standard_Integer);
+ Check_Arg_Is_OK_Static_Expression (Lower_Bound, Standard_Integer);
Lower_Val := Expr_Value (Lower_Bound);
Upper_Bound := Get_Pragma_Arg (Arg3);
- Check_Arg_Is_Static_Expression (Upper_Bound, Standard_Integer);
+ Check_Arg_Is_OK_Static_Expression (Upper_Bound, Standard_Integer);
Upper_Val := Expr_Value (Upper_Bound);
-- It is not allowed to use Task_Dispatching_Policy and
Arg := Get_Pragma_Arg (Arg1);
Preanalyze_Spec_Expression (Arg, Any_Integer);
- if not Is_Static_Expression (Arg) then
+ if not Is_OK_Static_Expression (Arg) then
Check_Restriction (Static_Storage_Size, Arg);
end if;
GNAT_Pragma;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Subtitle);
- Check_Arg_Is_Static_Expression (Arg1, Standard_String);
+ Check_Arg_Is_OK_Static_Expression (Arg1, Standard_String);
Store_Note (N);
--------------
Error_Pragma_Arg
("pragma% takes two arguments", Task_Type);
else
- Check_Arg_Is_Static_Expression (Top_Guard, Any_Integer);
+ Check_Arg_Is_OK_Static_Expression (Top_Guard, Any_Integer);
end if;
Check_First_Subtype (Task_Type);
Check_Arg_Count (1);
Check_No_Identifiers;
Check_In_Main_Program;
- Check_Arg_Is_Static_Expression (Arg1, Standard_Duration);
+ Check_Arg_Is_OK_Static_Expression (Arg1, Standard_Duration);
if not Error_Posted (Arg1) then
Nod := Next (N);
for J in 1 .. 2 loop
if Present (Args (J)) then
- Check_Arg_Is_Static_Expression (Args (J), Standard_String);
+ Check_Arg_Is_OK_Static_Expression
+ (Args (J), Standard_String);
end if;
end loop;
end Title;
return Ekind (Ent) = E_Constant
and then Present (Constant_Value (Ent))
and then
- Is_Static_Expression (Constant_Value (Ent));
+ Is_OK_Static_Expression (Constant_Value (Ent));
end;
else
Nalts := 0;
Alt := First (Alternatives (N));
while Present (Alt) loop
- if Is_Static_Expression (Alt)
+ if Is_OK_Static_Expression (Alt)
and then (Nkind_In (Alt, N_Integer_Literal,
N_Character_Literal)
or else Nkind (Alt) in N_Has_Entity)
if Present (Alternatives (N)) then
Resolve_Set_Membership;
- Check_Function_Writable_Actuals (N);
- return;
+ goto SM_Exit;
elsif not Is_Overloaded (R)
and then
Check_Unset_Reference (R);
end if;
+ -- Here after resolving membership operation
+
+ <<SM_Exit>>
+
Eval_Membership_Op (N);
Check_Function_Writable_Actuals (N);
end Resolve_Membership_Op;
-- separately on each final operand, past concatenation operations.
if Is_Character_Type (Etype (Arg)) then
- if not Is_Static_Expression (Arg) then
+ if not Is_OK_Static_Expression (Arg) then
Check_SPARK_Restriction
("character operand for concatenation should be static", Arg);
end if;
elsif Is_String_Type (Etype (Arg)) then
if not (Nkind_In (Arg, N_Identifier, N_Expanded_Name)
and then Is_Constant_Object (Entity (Arg)))
- and then not Is_Static_Expression (Arg)
+ and then not Is_OK_Static_Expression (Arg)
then
Check_SPARK_Restriction
("string operand for concatenation should be static", Arg);
if Is_Discrete_Type (Typ) and then Expander_Active then
if Is_OK_Static_Expression (L) then
- Fold_Uint (L, Expr_Value (L), Is_Static_Expression (L));
+ Fold_Uint (L, Expr_Value (L), Is_OK_Static_Expression (L));
end if;
if Is_OK_Static_Expression (H) then
- Fold_Uint (H, Expr_Value (H), Is_Static_Expression (H));
+ Fold_Uint (H, Expr_Value (H), Is_OK_Static_Expression (H));
end if;
end if;
end Resolve_Range;
-- Generate a warning if literal from source
- if Is_Static_Expression (N)
+ if Is_OK_Static_Expression (N)
and then Warn_On_Bad_Fixed_Value
then
Error_Msg_N
-- by truncation, since Machine_Rounds is false for all GNAT
-- fixed-point types (RM 4.9(38)).
- Stat := Is_Static_Expression (N);
+ Stat := Is_OK_Static_Expression (N);
Rewrite (N,
Make_Real_Literal (Sloc (N),
Realval => Small_Value (Typ) * Cint));
end if;
end Check_Dynamically_Tagged_Expression;
- -----------------------------------------------
- -- Check_Expression_Against_Static_Predicate --
- -----------------------------------------------
-
- procedure Check_Expression_Against_Static_Predicate
- (Expr : Node_Id;
- Typ : Entity_Id)
- is
- begin
- -- When the predicate is static and the value of the expression is known
- -- at compile time, evaluate the predicate check. A type is non-static
- -- when it has aspect Dynamic_Predicate, but if the dynamic predicate
- -- was predicate-static, we still check it statically. After all this
- -- is only a warning, not an error.
-
- if Compile_Time_Known_Value (Expr)
- and then Has_Predicates (Typ)
- and then Has_Static_Predicate (Typ)
- then
- -- Either -gnatc is enabled or the expression is ok
-
- if Operating_Mode < Generate_Code
- or else Eval_Static_Predicate_Check (Expr, Typ)
- then
- null;
-
- -- The expression is prohibited by the static predicate. There has
- -- been some debate if this is an illegality (in the case where
- -- the static predicate was explicitly given as such), but that
- -- discussion decided this was not illegal, just a warning situation.
-
- else
- Error_Msg_NE
- ("??static expression fails predicate check on &", Expr, Typ);
-
- -- We now reset the static expression indication on the expression
- -- since it is no longer static if it fails a predicate test. We
- -- do not do this if the predicate was officially dynamic, since
- -- dynamic predicates don't affect legality in this manner.
-
- if not Has_Dynamic_Predicate_Aspect (Typ) then
- Error_Msg_N
- ("\??expression is no longer considered static", Expr);
- Set_Is_Static_Expression (Expr, False);
- end if;
- end if;
- end if;
- end Check_Expression_Against_Static_Predicate;
-
--------------------------
-- Check_Fully_Declared --
--------------------------
return;
end if;
- if Nkind (N) in N_Subexpr and then Is_Static_Expression (N) then
+ if Nkind (N) in N_Subexpr and then Is_OK_Static_Expression (N) then
return;
end if;
-- bounds.
else
- pragma Assert (Is_Static_Expression (Choice)
+ pragma Assert (Is_OK_Static_Expression (Choice)
or else Nkind (Choice) = N_Identifier
or else Nkind (Choice) = N_Integer_Literal);
if Present (Expressions (N)) then
Comp_Expr := First (Expressions (N));
while Present (Comp_Expr) loop
- if not Is_Static_Expression (Comp_Expr) then
+ if not Is_OK_Static_Expression (Comp_Expr) then
Collect_Identifiers (Comp_Expr);
end if;
Msgl : Natural;
Wmsg : Boolean;
- P : Node_Id;
- OldP : Node_Id;
- Msgs : Boolean;
Eloc : Source_Ptr;
+ -- Start of processing for Compile_Time_Constraint_Error
+
begin
-- If this is a warning, convert it into an error if we are in code
-- subject to SPARK_Mode being set ON.
Msgc (Msgl) := '!';
end if;
- -- Should we generate a warning? The answer is not quite yes. The
- -- very annoying exception occurs in the case of a short circuit
- -- operator where the left operand is static and decisive. Climb
- -- parents to see if that is the case we have here. Conditional
- -- expressions with decisive conditions are a similar situation.
-
- Msgs := True;
- P := N;
- loop
- OldP := P;
- P := Parent (P);
-
- -- And then with False as left operand
-
- if Nkind (P) = N_And_Then
- and then Compile_Time_Known_Value (Left_Opnd (P))
- and then Is_False (Expr_Value (Left_Opnd (P)))
- then
- Msgs := False;
- exit;
+ -- One more test, skip the warning if the related expression is
+ -- statically unevaluated, since we don't want to warn about what
+ -- will happen when something is evaluated if it never will be
+ -- evaluated.
- -- OR ELSE with True as left operand
-
- elsif Nkind (P) = N_Or_Else
- and then Compile_Time_Known_Value (Left_Opnd (P))
- and then Is_True (Expr_Value (Left_Opnd (P)))
- then
- Msgs := False;
- exit;
-
- -- If expression
-
- elsif Nkind (P) = N_If_Expression then
- declare
- Cond : constant Node_Id := First (Expressions (P));
- Texp : constant Node_Id := Next (Cond);
- Fexp : constant Node_Id := Next (Texp);
-
- begin
- if Compile_Time_Known_Value (Cond) then
-
- -- Condition is True and we are in the right operand
-
- if Is_True (Expr_Value (Cond))
- and then OldP = Fexp
- then
- Msgs := False;
- exit;
-
- -- Condition is False and we are in the left operand
-
- elsif Is_False (Expr_Value (Cond))
- and then OldP = Texp
- then
- Msgs := False;
- exit;
- end if;
- end if;
- end;
-
- -- Special case for component association in aggregates, where
- -- we want to keep climbing up to the parent aggregate.
-
- elsif Nkind (P) = N_Component_Association
- and then Nkind (Parent (P)) = N_Aggregate
- then
- null;
-
- -- Keep going if within subexpression
-
- else
- exit when Nkind (P) not in N_Subexpr;
- end if;
- end loop;
-
- if Msgs then
+ if not Is_Statically_Unevaluated (N) then
Error_Msg_Warn := SPARK_Mode /= On;
if Present (Ent) then
Is_Array_Aggr : Boolean;
begin
- if Is_Static_Expression (N) then
+ if Is_OK_Static_Expression (N) then
return True;
elsif Nkind (N) = N_Null then
null;
elsif Nkind (Choice) = N_Range then
- if not Is_Static_Range (Choice) then
+ if not Is_OK_Static_Range (Choice) then
return False;
end if;
- elsif not Is_Static_Expression (Choice) then
+ elsif not Is_OK_Static_Expression (Choice) then
return False;
end if;
L_Index := First_Index (L_Typ);
Get_Index_Bounds (L_Index, L_Low, L_High);
- if Is_OK_Static_Expression (L_Low)
- and then Is_OK_Static_Expression (L_High)
+ if Is_OK_Static_Expression (L_Low)
+ and then
+ Is_OK_Static_Expression (L_High)
then
if Expr_Value (L_High) < Expr_Value (L_Low) then
L_Len := Uint_0;
R_Index := First_Index (R_Typ);
Get_Index_Bounds (R_Index, R_Low, R_High);
- if Is_OK_Static_Expression (R_Low)
- and then Is_OK_Static_Expression (R_High)
+ if Is_OK_Static_Expression (R_Low)
+ and then
+ Is_OK_Static_Expression (R_High)
then
if Expr_Value (R_High) < Expr_Value (R_Low) then
R_Len := Uint_0;
end if;
end if;
- if Is_OK_Static_Expression (L_Low)
- and then Is_OK_Static_Expression (R_Low)
+ if (Is_OK_Static_Expression (L_Low)
+ and then
+ Is_OK_Static_Expression (R_Low))
and then Expr_Value (L_Low) = Expr_Value (R_Low)
and then L_Len = R_Len
then
Get_Index_Bounds (L_Index, L_Low, L_High);
Get_Index_Bounds (R_Index, R_Low, R_High);
- if Is_OK_Static_Expression (L_Low)
- and then Is_OK_Static_Expression (L_High)
- and then Is_OK_Static_Expression (R_Low)
- and then Is_OK_Static_Expression (R_High)
- and then Expr_Value (L_Low) = Expr_Value (R_Low)
- and then Expr_Value (L_High) = Expr_Value (R_High)
+ if (Is_OK_Static_Expression (L_Low) and then
+ Is_OK_Static_Expression (L_High) and then
+ Is_OK_Static_Expression (R_Low) and then
+ Is_OK_Static_Expression (R_High))
+ and then (Expr_Value (L_Low) = Expr_Value (R_Low)
+ and then
+ Expr_Value (L_High) = Expr_Value (R_High))
then
null;
else
return No_Uint;
end if;
- if Is_Static_Expression (N) then
+ if Is_OK_Static_Expression (N) then
if not Raises_Constraint_Error (N) then
return Expr_Value (N);
else
return No_Uint;
end if;
- if Is_Static_Expression (N) then
+ if Is_OK_Static_Expression (N) then
if not Raises_Constraint_Error (N) then
return Expr_Value (N);
else
Related_Nod : Node_Id);
-- Check wrong use of dynamically tagged expression
- procedure Check_Expression_Against_Static_Predicate
- (Expr : Node_Id;
- Typ : Entity_Id);
- -- Determine whether an arbitrary expression satisfies the static predicate
- -- of a type. The routine does nothing if Expr is not known at compile time
- -- or Typ lacks a static predicate, otherwise it may emit a warning if the
- -- expression is prohibited by the predicate.
-
procedure Check_Fully_Declared (T : Entity_Id; N : Node_Id);
-- Verify that the full declaration of type T has been seen. If not, place
-- error message on node N. Used in object declarations, type conversions
-- of an object allocated on the stack rather than the heap.
-- Is_Static_Expression (Flag6-Sem)
- -- Indicates that an expression is a static expression (RM 4.9). See spec
- -- of package Sem_Eval for full details on the use of this flag.
+ -- Indicates that an expression is a static expression according to the
+ -- rules in (RM 4.9). Note that it is possible for this flag to be set
+ -- when Raises_Constraint_Error is also set. In practice almost all cases
+ -- where a static expression is required do not allow an expression which
+ -- raises Constraint_Error, so almost always, callers should call the
+ -- Is_Ok_Static_Exprression routine instead of testing this flag. See
+ -- spec of package Sem_Eval for full details on the use of this flag.
-- Is_Subprogram_Descriptor (Flag16-Sem)
-- Present in N_Object_Declaration, and set only for the object
return
Make_Raise_Constraint_Error (Sloc,
Condition => Condition,
- Reason =>
- UI_From_Int (RT_Exception_Code'Pos (Reason)));
+ Reason => UI_From_Int (RT_Exception_Code'Pos (Reason)));
end Make_Raise_Constraint_Error;
------------------------------
return
Make_Raise_Program_Error (Sloc,
Condition => Condition,
- Reason =>
- UI_From_Int (RT_Exception_Code'Pos (Reason)));
+ Reason => UI_From_Int (RT_Exception_Code'Pos (Reason)));
end Make_Raise_Program_Error;
------------------------------
return
Make_Raise_Storage_Error (Sloc,
Condition => Condition,
- Reason =>
- UI_From_Int (RT_Exception_Code'Pos (Reason)));
+ Reason => UI_From_Int (RT_Exception_Code'Pos (Reason)));
end Make_Raise_Storage_Error;
-------------
begin
Start_String;
Store_String_Chars (Strval);
- return
- Make_String_Literal (Sloc,
- Strval => End_String);
+ return Make_String_Literal (Sloc, Strval => End_String);
end Make_String_Literal;
--------------------
Related_Node : Node_Id := Empty) return Entity_Id
is
Temp : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name (Id));
+ Make_Defining_Identifier (Loc, Chars => New_Internal_Name (Id));
begin
Set_Related_Expression (Temp, Related_Node);
return Temp;
Set_Etype (Occurrence, Etype (Def_Id));
end if;
+ if Ekind (Def_Id) = E_Enumeration_Literal then
+ Set_Is_Static_Expression (Occurrence, True);
+ end if;
+
return Occurrence;
end New_Occurrence_Of;
-- of the defining identifier which is passed as its argument. The Entity
-- and Etype of the result are set from the given defining identifier as
-- follows: Entity is simply a copy of Def_Id. Etype is a copy of Def_Id
- -- for types, and a copy of the Etype of Def_Id for other entities.
+ -- for types, and a copy of the Etype of Def_Id for other entities. Note
+ -- that Is_Static_Expression is set if this call creates an occurrence of
+ -- an enumeration literal.
function New_Suffixed_Name
(Related_Id : Name_Id;
projects / platform / upstream / linaro-gcc.git / commitdiff