diff options
| author | Robert Dewar <dewar@adacore.com> | 2014-07-29 12:56:31 +0000 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2014-07-29 14:56:31 +0200 |
| commit | edab608853d34224b204dc42d751a3f90daabe39 (patch) | |
| tree | 6cc8f3aef60cefb58f69e4a2c8d62232b4c13f10 /gcc/ada | |
| parent | c5c780e6deb9cf337f4898db5716659698311d7d (diff) | |
| download | gcc-edab608853d34224b204dc42d751a3f90daabe39.zip gcc-edab608853d34224b204dc42d751a3f90daabe39.tar.gz gcc-edab608853d34224b204dc42d751a3f90daabe39.tar.bz2 | |
sem_aggr.adb (Resolve_Array_Aggregate): Change Is_Static_Range to Is_OK_Static_Range.
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
Diffstat (limited to 'gcc/ada')
33 files changed, 1481 insertions, 702 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7d2e4ce..40e3d18 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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 diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index d055306..d875cb5 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -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)); diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index e1b538d..7244e3c 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -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 diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 3422ac0..135de48 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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 diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index de784b2..5a1c288 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -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 diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 0232d67..e96f432 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -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; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index f454768..38327e9 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 96aa7f1..d8ce961 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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 diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 338050e..8c76981 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -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); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 51c49fd..a1d080a 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 8faf334..29a6e85 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -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))))) diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index bf678b6..ddd162f 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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 diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb index bd0ae5c..06cd956 100644 --- a/gcc/ada/lib-writ.adb +++ b/gcc/ada/lib-writ.adb @@ -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)); diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 0fe1937..5171398 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -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; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 114f42e..8502c42 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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; -------------------------------- diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index b9800c4..9a65a05 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -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; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 24dfa4e..cd55b58 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -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 diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 390fce7..9c9c6da 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 1f89f2e..e247e66 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 3dc457d..81d3841 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -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 diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index d90a7e5..26acb3b 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -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; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index bd9e4ec..c29d5c5 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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 diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index fb47956..00f9abe 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -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; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 67e43e1..27e1d20 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -123,6 +123,11 @@ package body Sem_Eval is 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)); @@ -137,6 +142,37 @@ package body Sem_Eval is -- 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 @@ -144,6 +180,32 @@ package body Sem_Eval is -- (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 @@ -254,6 +316,73 @@ package body Sem_Eval is 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 -- ------------------------------ @@ -421,6 +550,167 @@ package body Sem_Eval is 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 -- -------------------------- @@ -747,9 +1037,9 @@ package body Sem_Eval is -- 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; @@ -1565,8 +1855,11 @@ package body Sem_Eval is 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; @@ -1744,60 +2037,101 @@ package body Sem_Eval is -------------------------- -- 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; @@ -2001,8 +2335,17 @@ package body Sem_Eval is 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. @@ -2013,6 +2356,15 @@ package body Sem_Eval is 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 @@ -2020,43 +2372,31 @@ package body Sem_Eval 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; ---------------------------- @@ -2356,132 +2696,78 @@ package body Sem_Eval is 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; ------------------------ @@ -3297,53 +3583,6 @@ package body Sem_Eval is 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 -- ------------------------- @@ -4092,6 +4331,11 @@ package body Sem_Eval is 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 @@ -4120,6 +4364,11 @@ package body Sem_Eval is 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. @@ -4177,6 +4426,11 @@ package body Sem_Eval is 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. @@ -4400,6 +4654,60 @@ package body Sem_Eval is 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 -- ----------------------------- @@ -4502,7 +4810,56 @@ package body Sem_Eval is 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 -- --------------------- @@ -4513,7 +4870,7 @@ package body Sem_Eval is 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; @@ -4575,6 +4932,272 @@ package body Sem_Eval is 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 -- -------------------- @@ -4703,14 +5326,19 @@ package body Sem_Eval is ------------------------- 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); @@ -4721,7 +5349,7 @@ package body Sem_Eval is Rewrite (N, Exp); Set_Etype (N, Typ); - -- Else build an explcit N_Raise_CE + -- Else build an explicit N_Raise_CE else Rewrite (N, @@ -4730,6 +5358,11 @@ package body Sem_Eval is 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; --------------------- @@ -4772,9 +5405,9 @@ package body Sem_Eval is -- 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; @@ -4952,8 +5585,8 @@ package body Sem_Eval is -- 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; @@ -5041,8 +5674,8 @@ package body Sem_Eval is 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; @@ -5445,6 +6078,8 @@ package body Sem_Eval is 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 @@ -5488,6 +6123,76 @@ package body Sem_Eval is -- 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); @@ -5584,6 +6289,10 @@ package body Sem_Eval is 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 " @@ -5653,7 +6362,7 @@ package body Sem_Eval is ("!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 @@ -5747,7 +6456,7 @@ package body Sem_Eval is 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 " diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 207e28a..b4dbec8 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -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. diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb index 5fb7442..cfd6f04 100644 --- a/gcc/ada/sem_intr.adb +++ b/gcc/ada/sem_intr.adb @@ -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); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index c32d89b..b38d9a3 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -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; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 51b151e..ca4cc59 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -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)); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1716095..76cc667 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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. - - 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 @@ -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 diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 0dbd73a..d696341 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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 diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index f02fe51..1fb1acf 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -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 diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 17ca12e..3378dc7 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -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; diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index 67a59d9..4741661 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -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; |