mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-14 05:20:25 +08:00
Code Issues Packages Projects Releases Wiki Activity

sem_aggr.adb (Resolve_Array_Aggregate): Change Is_Static_Range to Is_OK_Static_Range.

Browse Source 
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.

From-SVN: r213159
This commit is contained in:
Robert Dewar 2014-07-29 12:56:31 +00:00 committed by Arnaud Charlet
parent c5c780e6de
commit edab608853
33 changed files with 1485 additions and 706 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
gcc/ada/ChangeLog
View File

@ -1,3 +1,37 @@
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

31
gcc/ada/checks.adb
View File

@ -5914,7 +5914,7 @@ package body Checks is
-- 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)
@ -5933,13 +5933,30 @@ package body Checks is
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);
@ -6876,7 +6893,7 @@ package body Checks is
--------------------------
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
@ -7148,7 +7165,7 @@ package body Checks is
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));

19
gcc/ada/checks.ads
View File

@ -660,12 +660,19 @@ package Checks is
-- 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

14
gcc/ada/einfo.ads
View File

@ -1878,13 +1878,13 @@ package Einfo is
-- 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

10
gcc/ada/exp_aggr.adb
View File

@ -5003,7 +5003,7 @@ package body Exp_Aggr is
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
@ -6634,10 +6634,10 @@ package body Exp_Aggr is
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

1
gcc/ada/exp_attr.adb
View File

@ -6010,7 +6010,6 @@ package body Exp_Attr is
-- 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;

13
gcc/ada/exp_ch3.adb
View File

@ -5722,13 +5722,18 @@ package body Exp_Ch3 is
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;

5
gcc/ada/exp_ch4.adb
View File

@ -1386,7 +1386,6 @@ package body Exp_Ch4 is
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;
@ -1402,7 +1401,6 @@ package body Exp_Ch4 is
(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;
@ -9650,7 +9648,7 @@ package body Exp_Ch4 is
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;
@ -10946,6 +10944,7 @@ package body Exp_Ch4 is
-- 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

5
gcc/ada/exp_ch5.adb
View File

@ -1734,7 +1734,6 @@ package body Exp_Ch5 is
-- 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;
@ -4061,7 +4060,7 @@ package body Exp_Ch5 is
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);
@ -4075,7 +4074,7 @@ package body Exp_Ch5 is
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);

2
gcc/ada/exp_ch6.adb
View File

@ -2753,7 +2753,6 @@ package body Exp_Ch6 is
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;
@ -3676,7 +3675,6 @@ package body Exp_Ch6 is
-- 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;

2
gcc/ada/exp_ch9.adb
View File

@ -11675,7 +11675,7 @@ package body Exp_Ch9 is
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)))))

34
gcc/ada/freeze.adb
View File

@ -4241,12 +4241,12 @@ package body Freeze is
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 "
@ -5398,7 +5398,7 @@ package body Freeze 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);
@ -5647,21 +5647,21 @@ package body Freeze is
-- 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;
@ -6607,7 +6607,7 @@ package body Freeze is
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

5
gcc/ada/lib-writ.adb
View File

@ -44,6 +44,7 @@ with Par_SCO; use Par_SCO;
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;
@ -697,12 +698,12 @@ package body Lib.Writ is
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));

18
gcc/ada/sem_aggr.adb
View File

@ -993,7 +993,7 @@ package body Sem_Aggr is
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;
@ -1611,10 +1611,12 @@ package body Sem_Aggr is
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;
@ -1899,9 +1901,9 @@ package body Sem_Aggr is
-- 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);
@ -3425,10 +3427,12 @@ package body Sem_Aggr is
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;

302
gcc/ada/sem_attr.adb
View File

@ -406,7 +406,8 @@ package body Sem_Attr is
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)
@ -1241,7 +1242,7 @@ package body Sem_Attr is
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
@ -1499,7 +1500,7 @@ package body Sem_Attr is
-- 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;
@ -2260,6 +2261,7 @@ package body Sem_Attr is
Check_Standard_Prefix;
Rewrite (N, Make_Integer_Literal (Loc, Val));
Analyze (N);
Set_Is_Static_Expression (N, True);
end Standard_Attribute;
-------------------------
@ -2312,7 +2314,8 @@ package body Sem_Attr is
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);
@ -2998,6 +3001,7 @@ package body Sem_Attr is
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 --
@ -3410,8 +3414,7 @@ package body Sem_Attr is
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 " &
@ -4256,7 +4259,7 @@ package body Sem_Attr is
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;
@ -5870,6 +5873,7 @@ package body Sem_Attr is
Make_String_Literal (Loc,
Strval => TN (TN'First .. TL)));
Analyze_And_Resolve (N, Standard_String);
Set_Is_Static_Expression (N, True);
end Target_Name;
----------------
@ -5897,7 +5901,11 @@ package body Sem_Attr is
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);
@ -5927,6 +5935,8 @@ package body Sem_Attr is
Set_Etype (E1, Standard_Unsigned_64);
end if;
end if;
Set_Is_Static_Expression (N, True);
end To_Address;
------------
@ -6047,6 +6057,7 @@ package body Sem_Attr is
Check_Type;
Check_Not_Incomplete_Type;
Set_Etype (N, Standard_Boolean);
Set_Is_Static_Expression (N, True);
------------------------------
-- Universal_Literal_String --
@ -6111,6 +6122,7 @@ package body Sem_Attr is
Rewrite (N,
Make_String_Literal (Loc, End_String));
Analyze (N);
Set_Is_Static_Expression (N, True);
end;
end if;
end Universal_Literal_String;
@ -6764,7 +6776,11 @@ package body Sem_Attr is
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
@ -7098,8 +7114,16 @@ package body Sem_Attr is
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;
@ -7125,6 +7149,11 @@ package body Sem_Attr is
-- 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).
@ -7191,10 +7220,8 @@ package body Sem_Attr is
-- 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
@ -7234,7 +7261,7 @@ package body Sem_Attr is
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
@ -7269,11 +7296,56 @@ package body Sem_Attr is
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
@ -7312,28 +7384,19 @@ package body Sem_Attr is
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
@ -7427,7 +7490,12 @@ package body Sem_Attr is
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,
@ -7443,25 +7511,18 @@ package body Sem_Attr is
-- 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)
@ -7486,14 +7547,15 @@ package body Sem_Attr is
-- 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
@ -7502,21 +7564,28 @@ package body Sem_Attr is
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;
@ -7541,6 +7610,11 @@ package body Sem_Attr is
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
@ -7601,7 +7675,7 @@ package body Sem_Attr is
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;
@ -7658,7 +7732,7 @@ package body Sem_Attr is
---------
when Attribute_Aft =>
Fold_Uint (N, Aft_Value (P_Type), True);
Fold_Uint (N, Aft_Value (P_Type), Static);
---------------
-- Alignment --
@ -7671,7 +7745,7 @@ package body Sem_Attr is
-- 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;
@ -7710,7 +7784,8 @@ package body Sem_Attr is
-- 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;
---------
@ -7745,7 +7820,7 @@ package body Sem_Attr is
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;
-------------
@ -7801,7 +7876,7 @@ package body Sem_Attr is
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 --
@ -7815,7 +7890,7 @@ package body Sem_Attr is
------------
when Attribute_Digits =>
Fold_Uint (N, Digits_Value (P_Type), True);
Fold_Uint (N, Digits_Value (P_Type), Static);
----------
-- Emax --
@ -7827,7 +7902,7 @@ package body Sem_Attr is
-- T'Emax = 4 * T'Mantissa
Fold_Uint (N, 4 * Mantissa, True);
Fold_Uint (N, 4 * Mantissa, Static);
--------------
-- Enum_Rep --
@ -8153,7 +8228,8 @@ package body Sem_Attr is
-- static attribute in GNAT.
Analyze_And_Resolve (N, Standard_Boolean);
Static := True;
Static := True;
Set_Is_Static_Expression (N, True);
end Lock_Free;
----------
@ -8252,7 +8328,7 @@ package body Sem_Attr is
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
@ -8267,14 +8343,14 @@ package body Sem_Attr is
(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 =>
@ -8336,14 +8412,14 @@ package body Sem_Attr is
-- 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;
-------------------
@ -8355,15 +8431,15 @@ package body Sem_Attr is
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;
----------------------
@ -8389,13 +8465,14 @@ package body Sem_Attr is
-- 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;
------------------
@ -8409,7 +8486,7 @@ package body Sem_Attr is
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;
@ -8482,7 +8559,7 @@ package body Sem_Attr is
Siz := Siz + 1;
end loop;
Fold_Uint (N, Siz, True);
Fold_Uint (N, Siz, Static);
end;
else
@ -8495,7 +8572,7 @@ package body Sem_Attr is
-- Floating-point Mantissa
else
Fold_Uint (N, Mantissa, True);
Fold_Uint (N, Mantissa, Static);
end if;
---------
@ -8576,7 +8653,7 @@ package body Sem_Attr is
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;
@ -8644,7 +8721,7 @@ package body Sem_Attr is
-------------
when Attribute_Modulus =>
Fold_Uint (N, Modulus (P_Type), True);
Fold_Uint (N, Modulus (P_Type), Static);
--------------------
-- Null_Parameter --
@ -8669,7 +8746,7 @@ package body Sem_Attr is
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;
@ -8687,14 +8764,14 @@ package body Sem_Attr is
-- 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 --
@ -8782,14 +8859,14 @@ package body Sem_Attr is
(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 =>
@ -8802,7 +8879,7 @@ package body Sem_Attr is
---------
when Attribute_Ref =>
Fold_Uint (N, Expr_Value (E1), True);
Fold_Uint (N, Expr_Value (E1), Static);
---------------
-- Remainder --
@ -8924,7 +9001,7 @@ package body Sem_Attr is
-----------
when Attribute_Scale =>
Fold_Uint (N, Scale_Value (P_Type), True);
Fold_Uint (N, Scale_Value (P_Type), Static);
-------------
-- Scaling --
@ -8951,13 +9028,15 @@ package body Sem_Attr is
-- 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
@ -8982,23 +9061,21 @@ package body Sem_Attr is
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;
@ -9179,6 +9256,7 @@ package body Sem_Attr is
Analyze_And_Resolve (N, Standard_Boolean);
Static := True;
Set_Is_Static_Expression (N, True);
end Unconstrained_Array;
-- Attribute Update is never static
@ -9219,15 +9297,16 @@ package body Sem_Attr is
-- 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;
@ -9293,7 +9372,7 @@ package body Sem_Attr is
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
@ -9318,7 +9397,7 @@ package body Sem_Attr is
Len := Len + 8;
end if;
Fold_Uint (N, UI_From_Int (Len), True);
Fold_Uint (N, UI_From_Int (Len), Static);
end;
end if;
@ -9331,7 +9410,7 @@ package body Sem_Attr is
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
@ -9340,7 +9419,7 @@ package body Sem_Attr is
Fold_Uint
(N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type),
True);
Static);
end if;
-- Discrete types
@ -9517,7 +9596,7 @@ package body Sem_Attr is
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;
@ -11034,15 +11113,12 @@ package body Sem_Attr is
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;
--------------------------------

5
gcc/ada/sem_cat.adb
View File

@ -355,7 +355,7 @@ package body Sem_Cat is
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
@ -815,7 +815,8 @@ package body Sem_Cat is
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;

5
gcc/ada/sem_ch12.adb
View File

@ -5336,9 +5336,8 @@ package body Sem_Ch12 is
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

40
gcc/ada/sem_ch13.adb
View File

@ -1688,10 +1688,10 @@ package body Sem_Ch13 is
-- 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
@ -1931,7 +1931,7 @@ package body Sem_Ch13 is
-- 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);
@ -4227,7 +4227,7 @@ package body Sem_Ch13 is
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);
@ -4367,7 +4367,7 @@ package body Sem_Ch13 is
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;
@ -4466,7 +4466,7 @@ package body Sem_Ch13 is
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;
@ -4700,7 +4700,7 @@ package body Sem_Ch13 is
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;
@ -4741,7 +4741,7 @@ package body Sem_Ch13 is
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);
@ -4896,7 +4896,7 @@ package body Sem_Ch13 is
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;
@ -5567,7 +5567,7 @@ package body Sem_Ch13 is
-- ??? 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;
@ -6737,7 +6737,7 @@ package body Sem_Ch13 is
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
@ -6781,7 +6781,7 @@ package body Sem_Ch13 is
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);
@ -6826,7 +6826,7 @@ package body Sem_Ch13 is
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);
@ -6860,9 +6860,9 @@ package body Sem_Ch13 is
-- 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
@ -6873,7 +6873,7 @@ package body Sem_Ch13 is
-- 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));
@ -6892,7 +6892,7 @@ package body Sem_Ch13 is
-- 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));
@ -9606,7 +9606,7 @@ package body Sem_Ch13 is
-- 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;

6
gcc/ada/sem_ch3.adb
View File

@ -3154,7 +3154,7 @@ package body Sem_Ch3 is
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
@ -17370,7 +17370,7 @@ package body Sem_Ch3 is
-- 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;
@ -18984,7 +18984,7 @@ package body Sem_Ch3 is
-- 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;

2
gcc/ada/sem_ch4.adb
View File

@ -1467,7 +1467,7 @@ package body Sem_Ch4 is
-- 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

4
gcc/ada/sem_ch5.adb
View File

@ -2317,11 +2317,11 @@ package body Sem_Ch5 is
-- 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;

2
gcc/ada/sem_ch6.adb
View File

@ -5249,7 +5249,7 @@ package body Sem_Ch6 is
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

11
gcc/ada/sem_ch9.adb
View File

@ -304,7 +304,8 @@ package body Sem_Ch9 is
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));
@ -389,7 +390,7 @@ package body Sem_Ch9 is
-- 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
@ -427,7 +428,7 @@ package body Sem_Ch9 is
-- 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
@ -1557,7 +1558,7 @@ package body Sem_Ch9 is
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;
@ -1583,7 +1584,7 @@ package body Sem_Ch9 is
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;

1157
gcc/ada/sem_eval.adb
View File

File diff suppressed because it is too large Load Diff

106
gcc/ada/sem_eval.ads
View File

@ -63,17 +63,38 @@ package Sem_Eval is
-- (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 --
-------------------------------
@ -107,6 +128,17 @@ package Sem_Eval is
-- 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
@ -181,18 +213,14 @@ package Sem_Eval is
-- 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
@ -205,13 +233,27 @@ package Sem_Eval is
-- 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;
@ -364,14 +406,6 @@ package Sem_Eval is
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
@ -381,7 +415,8 @@ package Sem_Eval is
-- 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)
@ -393,7 +428,8 @@ package Sem_Eval is
-- 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
@ -404,6 +440,8 @@ package Sem_Eval is
-- 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;
@ -460,6 +498,10 @@ package Sem_Eval is
-- 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)
@ -487,7 +529,7 @@ package Sem_Eval is
--
-- 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.

4
gcc/ada/sem_intr.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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- --
@ -137,7 +137,7 @@ package body Sem_Intr is
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);

112
gcc/ada/sem_prag.adb
View File

@ -1852,7 +1852,7 @@ package body Sem_Prag is
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);
@ -2890,14 +2890,15 @@ package body Sem_Prag is
-- 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
@ -2941,14 +2942,15 @@ package body Sem_Prag is
-- 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
@ -3702,7 +3704,7 @@ package body Sem_Prag is
-- 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)
@ -3987,17 +3989,17 @@ package body Sem_Prag is
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 --
@ -4341,11 +4343,11 @@ package body Sem_Prag is
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
@ -4376,7 +4378,7 @@ package body Sem_Prag 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
@ -4388,7 +4390,7 @@ package body Sem_Prag is
Expr);
raise Pragma_Exit;
end if;
end Check_Expr_Is_Static_Expression;
end Check_Expr_Is_OK_Static_Expression;
-------------------------
-- Check_First_Subtype --
@ -5450,13 +5452,13 @@ package body Sem_Prag is
((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;
@ -6410,7 +6412,7 @@ package body Sem_Prag is
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
@ -7214,7 +7216,7 @@ package body Sem_Prag is
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
@ -8237,7 +8239,8 @@ package body Sem_Prag is
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
@ -8256,7 +8259,7 @@ package body Sem_Prag is
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;
@ -8749,7 +8752,7 @@ package body Sem_Prag is
-- 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,
@ -8794,7 +8797,7 @@ package body Sem_Prag is
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;
@ -10373,7 +10376,7 @@ package body Sem_Prag is
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
@ -11897,7 +11900,7 @@ package body Sem_Prag is
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);
@ -12879,7 +12882,7 @@ package body Sem_Prag is
-- 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;
@ -13991,10 +13994,10 @@ package body Sem_Prag is
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 --
@ -14478,7 +14481,7 @@ package body Sem_Prag is
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
@ -15700,7 +15703,7 @@ package body Sem_Prag is
-- 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))
@ -15787,7 +15790,7 @@ package body Sem_Prag is
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);
@ -16256,12 +16259,12 @@ package body Sem_Prag is
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
@ -16336,7 +16339,7 @@ package body Sem_Prag is
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
@ -16409,12 +16412,12 @@ package body Sem_Prag is
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))));
@ -16447,7 +16450,7 @@ package body Sem_Prag is
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
@ -16743,7 +16746,7 @@ package body Sem_Prag is
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;
@ -16751,7 +16754,7 @@ package body Sem_Prag is
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
@ -16803,12 +16806,12 @@ package body Sem_Prag is
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);
@ -16849,7 +16852,7 @@ package body Sem_Prag is
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;
@ -17143,7 +17146,7 @@ package body Sem_Prag is
-- 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
@ -18272,7 +18275,7 @@ package body Sem_Prag is
-- 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;
@ -18383,11 +18386,11 @@ package body Sem_Prag is
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
@ -20054,7 +20057,7 @@ package body Sem_Prag is
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;
@ -20330,7 +20333,7 @@ package body Sem_Prag is
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);
--------------
@ -20622,7 +20625,7 @@ package body Sem_Prag is
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);
@ -20700,7 +20703,7 @@ package body Sem_Prag is
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);
@ -20758,7 +20761,8 @@ package body Sem_Prag is
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;

23
gcc/ada/sem_res.adb
View File

@ -3401,7 +3401,7 @@ package body Sem_Res is
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
@ -8145,7 +8145,7 @@ package body Sem_Res is
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)
@ -8176,8 +8176,7 @@ package body Sem_Res is
if Present (Alternatives (N)) then
Resolve_Set_Membership;
Check_Function_Writable_Actuals (N);
return;
goto SM_Exit;
elsif not Is_Overloaded (R)
and then
@ -8240,6 +8239,10 @@ package body Sem_Res is
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;
@ -8502,7 +8505,7 @@ package body Sem_Res is
-- 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;
@ -8510,7 +8513,7 @@ package body Sem_Res is
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);
@ -8966,11 +8969,11 @@ package body Sem_Res is
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;
@ -9016,7 +9019,7 @@ package body Sem_Res is
-- 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
@ -9029,7 +9032,7 @@ package body Sem_Res is
-- 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));

178
gcc/ada/sem_util.adb
View File

@ -1684,55 +1684,6 @@ package body Sem_Util is
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 --
--------------------------
@ -1944,7 +1895,7 @@ package body Sem_Util is
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;
@ -2209,7 +2160,7 @@ package body Sem_Util is
-- 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);
@ -2280,7 +2231,7 @@ package body Sem_Util is
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;
@ -3602,11 +3553,10 @@ package body Sem_Util is
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.
@ -3677,82 +3627,12 @@ package body Sem_Util is
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.
-- 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.
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;
-- 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
@ -8034,7 +7914,7 @@ package body Sem_Util is
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
@ -8124,11 +8004,11 @@ package body Sem_Util is
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;
@ -12528,8 +12408,9 @@ package body Sem_Util is
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;
@ -12548,8 +12429,9 @@ package body Sem_Util is
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;
@ -12561,8 +12443,9 @@ package body Sem_Util is
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
@ -12580,12 +12463,13 @@ package body Sem_Util is
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
@ -16467,7 +16351,7 @@ package body Sem_Util is
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
@ -16499,7 +16383,7 @@ package body Sem_Util is
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

8
gcc/ada/sem_util.ads
View File

@ -250,14 +250,6 @@ package Sem_Util is
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

9
gcc/ada/sinfo.ads
View File

@ -1612,8 +1612,13 @@ package Sinfo is
-- 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

20
gcc/ada/tbuild.adb
View File

@ -438,8 +438,7 @@ package body Tbuild is
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;
------------------------------
@ -456,8 +455,7 @@ package body Tbuild is
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;
------------------------------
@ -474,8 +472,7 @@ package body Tbuild is
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;
-------------
@ -501,9 +498,7 @@ package body Tbuild is
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;
--------------------
@ -516,8 +511,7 @@ package body Tbuild is
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;
@ -694,6 +688,10 @@ package body Tbuild is
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;

4
gcc/ada/tbuild.ads
View File

@ -300,7 +300,9 @@ package Tbuild is
-- 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;