1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S E M _ E V A L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2020, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Aspects; use Aspects; 27with Atree; use Atree; 28with Checks; use Checks; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Elists; use Elists; 32with Errout; use Errout; 33with Eval_Fat; use Eval_Fat; 34with Exp_Util; use Exp_Util; 35with Freeze; use Freeze; 36with Lib; use Lib; 37with Namet; use Namet; 38with Nmake; use Nmake; 39with Nlists; use Nlists; 40with Opt; use Opt; 41with Par_SCO; use Par_SCO; 42with Rtsfind; use Rtsfind; 43with Sem; use Sem; 44with Sem_Aux; use Sem_Aux; 45with Sem_Cat; use Sem_Cat; 46with Sem_Ch3; use Sem_Ch3; 47with Sem_Ch6; use Sem_Ch6; 48with Sem_Ch8; use Sem_Ch8; 49with Sem_Elab; use Sem_Elab; 50with Sem_Res; use Sem_Res; 51with Sem_Util; use Sem_Util; 52with Sem_Type; use Sem_Type; 53with Sem_Warn; use Sem_Warn; 54with Sinfo; use Sinfo; 55with Snames; use Snames; 56with Stand; use Stand; 57with Stringt; use Stringt; 58with Tbuild; use Tbuild; 59 60package body Sem_Eval is 61 62 ----------------------------------------- 63 -- Handling of Compile Time Evaluation -- 64 ----------------------------------------- 65 66 -- The compile time evaluation of expressions is distributed over several 67 -- Eval_xxx procedures. These procedures are called immediately after 68 -- a subexpression is resolved and is therefore accomplished in a bottom 69 -- up fashion. The flags are synthesized using the following approach. 70 71 -- Is_Static_Expression is determined by following the rules in 72 -- RM-4.9. This involves testing the Is_Static_Expression flag of 73 -- the operands in many cases. 74 75 -- Raises_Constraint_Error is usually set if any of the operands have 76 -- the flag set or if an attempt to compute the value of the current 77 -- expression results in Constraint_Error. 78 79 -- The general approach is as follows. First compute Is_Static_Expression. 80 -- If the node is not static, then the flag is left off in the node and 81 -- we are all done. Otherwise for a static node, we test if any of the 82 -- operands will raise Constraint_Error, and if so, propagate the flag 83 -- Raises_Constraint_Error to the result node and we are done (since the 84 -- error was already posted at a lower level). 85 86 -- For the case of a static node whose operands do not raise constraint 87 -- error, we attempt to evaluate the node. If this evaluation succeeds, 88 -- then the node is replaced by the result of this computation. If the 89 -- evaluation raises Constraint_Error, then we rewrite the node with 90 -- Apply_Compile_Time_Constraint_Error to raise the exception and also 91 -- to post appropriate error messages. 92 93 ---------------- 94 -- Local Data -- 95 ---------------- 96 97 type Bits is array (Nat range <>) of Boolean; 98 -- Used to convert unsigned (modular) values for folding logical ops 99 100 -- The following declarations are used to maintain a cache of nodes that 101 -- have compile-time-known values. The cache is maintained only for 102 -- discrete types (the most common case), and is populated by calls to 103 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value 104 -- since it is possible for the status to change (in particular it is 105 -- possible for a node to get replaced by a Constraint_Error node). 106 107 CV_Bits : constant := 5; 108 -- Number of low order bits of Node_Id value used to reference entries 109 -- in the cache table. 110 111 CV_Cache_Size : constant Nat := 2 ** CV_Bits; 112 -- Size of cache for compile time values 113 114 subtype CV_Range is Nat range 0 .. CV_Cache_Size; 115 116 type CV_Entry is record 117 N : Node_Id; 118 V : Uint; 119 end record; 120 121 type Match_Result is (Match, No_Match, Non_Static); 122 -- Result returned from functions that test for a matching result. If the 123 -- operands are not OK_Static then Non_Static will be returned. Otherwise 124 -- Match/No_Match is returned depending on whether the match succeeds. 125 126 type CV_Cache_Array is array (CV_Range) of CV_Entry; 127 128 CV_Cache : CV_Cache_Array; 129 -- This is the actual cache, with entries consisting of node/value pairs, 130 -- and the impossible value Node_High_Bound used for unset entries. 131 132 type Range_Membership is (In_Range, Out_Of_Range, Unknown); 133 -- Range membership may either be statically known to be in range or out 134 -- of range, or not statically known. Used for Test_In_Range below. 135 136 Checking_For_Potentially_Static_Expression : Boolean := False; 137 -- Global flag that is set True during Analyze_Static_Expression_Function 138 -- in order to verify that the result expression of a static expression 139 -- function is a potentially static function (see RM202x 6.8(5.3)). 140 141 ----------------------- 142 -- Local Subprograms -- 143 ----------------------- 144 145 function Choice_Matches 146 (Expr : Node_Id; 147 Choice : Node_Id) return Match_Result; 148 -- Determines whether given value Expr matches the given Choice. The Expr 149 -- can be of discrete, real, or string type and must be a compile time 150 -- known value (it is an error to make the call if these conditions are 151 -- not met). The choice can be a range, subtype name, subtype indication, 152 -- or expression. The returned result is Non_Static if Choice is not 153 -- OK_Static, otherwise either Match or No_Match is returned depending 154 -- on whether Choice matches Expr. This is used for case expression 155 -- alternatives, and also for membership tests. In each case, more 156 -- possibilities are tested than the syntax allows (e.g. membership allows 157 -- subtype indications and non-discrete types, and case allows an OTHERS 158 -- choice), but it does not matter, since we have already done a full 159 -- semantic and syntax check of the construct, so the extra possibilities 160 -- just will not arise for correct expressions. 161 -- 162 -- Note: if Choice_Matches finds that a choice raises Constraint_Error, e.g 163 -- a reference to a type, one of whose bounds raises Constraint_Error, then 164 -- it also sets the Raises_Constraint_Error flag on the Choice itself. 165 166 function Choices_Match 167 (Expr : Node_Id; 168 Choices : List_Id) return Match_Result; 169 -- This function applies Choice_Matches to each element of Choices. If the 170 -- result is No_Match, then it continues and checks the next element. If 171 -- the result is Match or Non_Static, this result is immediately given 172 -- as the result without checking the rest of the list. Expr can be of 173 -- discrete, real, or string type and must be a compile-time-known value 174 -- (it is an error to make the call if these conditions are not met). 175 176 procedure Eval_Intrinsic_Call (N : Node_Id; E : Entity_Id); 177 -- Evaluate a call N to an intrinsic subprogram E. 178 179 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id; 180 -- Check whether an arithmetic operation with universal operands which is a 181 -- rewritten function call with an explicit scope indication is ambiguous: 182 -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric 183 -- type declared in P and the context does not impose a type on the result 184 -- (e.g. in the expression of a type conversion). If ambiguous, emit an 185 -- error and return Empty, else return the result type of the operator. 186 187 procedure Fold_Dummy (N : Node_Id; Typ : Entity_Id); 188 -- Rewrite N as a constant dummy value in the relevant type if possible. 189 190 procedure Fold_Shift 191 (N : Node_Id; 192 Left : Node_Id; 193 Right : Node_Id; 194 Op : Node_Kind; 195 Static : Boolean := False; 196 Check_Elab : Boolean := False); 197 -- Rewrite N as the result of evaluating Left <shift op> Right if possible. 198 -- Op represents the shift operation. 199 -- Static indicates whether the resulting node should be marked static. 200 -- Check_Elab indicates whether checks for elaboration calls should be 201 -- inserted when relevant. 202 203 function From_Bits (B : Bits; T : Entity_Id) return Uint; 204 -- Converts a bit string of length B'Length to a Uint value to be used for 205 -- a target of type T, which is a modular type. This procedure includes the 206 -- necessary reduction by the modulus in the case of a nonbinary modulus 207 -- (for a binary modulus, the bit string is the right length any way so all 208 -- is well). 209 210 function Get_String_Val (N : Node_Id) return Node_Id; 211 -- Given a tree node for a folded string or character value, returns the 212 -- corresponding string literal or character literal (one of the two must 213 -- be available, or the operand would not have been marked as foldable in 214 -- the earlier analysis of the operation). 215 216 function Is_OK_Static_Choice (Choice : Node_Id) return Boolean; 217 -- Given a choice (from a case expression or membership test), returns 218 -- True if the choice is static and does not raise a Constraint_Error. 219 220 function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean; 221 -- Given a choice list (from a case expression or membership test), return 222 -- True if all choices are static in the sense of Is_OK_Static_Choice. 223 224 function Is_Static_Choice (Choice : Node_Id) return Boolean; 225 -- Given a choice (from a case expression or membership test), returns 226 -- True if the choice is static. No test is made for raising of constraint 227 -- error, so this function is used only for legality tests. 228 229 function Is_Static_Choice_List (Choices : List_Id) return Boolean; 230 -- Given a choice list (from a case expression or membership test), return 231 -- True if all choices are static in the sense of Is_Static_Choice. 232 233 function Is_Static_Range (N : Node_Id) return Boolean; 234 -- Determine if range is static, as defined in RM 4.9(26). The only allowed 235 -- argument is an N_Range node (but note that the semantic analysis of 236 -- equivalent range attribute references already turned them into the 237 -- equivalent range). This differs from Is_OK_Static_Range (which is what 238 -- must be used by clients) in that it does not care whether the bounds 239 -- raise Constraint_Error or not. Used for checking whether expressions are 240 -- static in the 4.9 sense (without worrying about exceptions). 241 242 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean; 243 -- Bits represents the number of bits in an integer value to be computed 244 -- (but the value has not been computed yet). If this value in Bits is 245 -- reasonable, a result of True is returned, with the implication that the 246 -- caller should go ahead and complete the calculation. If the value in 247 -- Bits is unreasonably large, then an error is posted on node N, and 248 -- False is returned (and the caller skips the proposed calculation). 249 250 procedure Out_Of_Range (N : Node_Id); 251 -- This procedure is called if it is determined that node N, which appears 252 -- in a non-static context, is a compile-time-known value which is outside 253 -- its range, i.e. the range of Etype. This is used in contexts where 254 -- this is an illegality if N is static, and should generate a warning 255 -- otherwise. 256 257 function Real_Or_String_Static_Predicate_Matches 258 (Val : Node_Id; 259 Typ : Entity_Id) return Boolean; 260 -- This is the function used to evaluate real or string static predicates. 261 -- Val is an unanalyzed N_Real_Literal or N_String_Literal node, which 262 -- represents the value to be tested against the predicate. Typ is the 263 -- type with the predicate, from which the predicate expression can be 264 -- extracted. The result returned is True if the given value satisfies 265 -- the predicate. 266 267 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id); 268 -- N and Exp are nodes representing an expression, Exp is known to raise 269 -- CE. N is rewritten in term of Exp in the optimal way. 270 271 function String_Type_Len (Stype : Entity_Id) return Uint; 272 -- Given a string type, determines the length of the index type, or, if 273 -- this index type is non-static, the length of the base type of this index 274 -- type. Note that if the string type is itself static, then the index type 275 -- is static, so the second case applies only if the string type passed is 276 -- non-static. 277 278 function Test (Cond : Boolean) return Uint; 279 pragma Inline (Test); 280 -- This function simply returns the appropriate Boolean'Pos value 281 -- corresponding to the value of Cond as a universal integer. It is 282 -- used for producing the result of the static evaluation of the 283 -- logical operators 284 285 procedure Test_Expression_Is_Foldable 286 (N : Node_Id; 287 Op1 : Node_Id; 288 Stat : out Boolean; 289 Fold : out Boolean); 290 -- Tests to see if expression N whose single operand is Op1 is foldable, 291 -- i.e. the operand value is known at compile time. If the operation is 292 -- foldable, then Fold is True on return, and Stat indicates whether the 293 -- result is static (i.e. the operand was static). Note that it is quite 294 -- possible for Fold to be True, and Stat to be False, since there are 295 -- cases in which we know the value of an operand even though it is not 296 -- technically static (e.g. the static lower bound of a range whose upper 297 -- bound is non-static). 298 -- 299 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes 300 -- a call to Check_Non_Static_Context on the operand. If Fold is False on 301 -- return, then all processing is complete, and the caller should return, 302 -- since there is nothing else to do. 303 -- 304 -- If Stat is set True on return, then Is_Static_Expression is also set 305 -- true in node N. There are some cases where this is over-enthusiastic, 306 -- e.g. in the two operand case below, for string comparison, the result is 307 -- not static even though the two operands are static. In such cases, the 308 -- caller must reset the Is_Static_Expression flag in N. 309 -- 310 -- If Fold and Stat are both set to False then this routine performs also 311 -- the following extra actions: 312 -- 313 -- If either operand is Any_Type then propagate it to result to prevent 314 -- cascaded errors. 315 -- 316 -- If some operand raises Constraint_Error, then replace the node N 317 -- with the raise Constraint_Error node. This replacement inherits the 318 -- Is_Static_Expression flag from the operands. 319 320 procedure Test_Expression_Is_Foldable 321 (N : Node_Id; 322 Op1 : Node_Id; 323 Op2 : Node_Id; 324 Stat : out Boolean; 325 Fold : out Boolean; 326 CRT_Safe : Boolean := False); 327 -- Same processing, except applies to an expression N with two operands 328 -- Op1 and Op2. The result is static only if both operands are static. If 329 -- CRT_Safe is set True, then CRT_Safe_Compile_Time_Known_Value is used 330 -- for the tests that the two operands are known at compile time. See 331 -- spec of this routine for further details. 332 333 function Test_In_Range 334 (N : Node_Id; 335 Typ : Entity_Id; 336 Assume_Valid : Boolean; 337 Fixed_Int : Boolean; 338 Int_Real : Boolean) return Range_Membership; 339 -- Common processing for Is_In_Range and Is_Out_Of_Range: Returns In_Range 340 -- or Out_Of_Range if it can be guaranteed at compile time that expression 341 -- N is known to be in or out of range of the subtype Typ. If not compile 342 -- time known, Unknown is returned. See documentation of Is_In_Range for 343 -- complete description of parameters. 344 345 procedure To_Bits (U : Uint; B : out Bits); 346 -- Converts a Uint value to a bit string of length B'Length 347 348 ----------------------------------------------- 349 -- Check_Expression_Against_Static_Predicate -- 350 ----------------------------------------------- 351 352 procedure Check_Expression_Against_Static_Predicate 353 (Expr : Node_Id; 354 Typ : Entity_Id; 355 Static_Failure_Is_Error : Boolean := False) 356 is 357 begin 358 -- Nothing to do if expression is not known at compile time, or the 359 -- type has no static predicate set (will be the case for all non-scalar 360 -- types, so no need to make a special test for that). 361 362 if not (Has_Static_Predicate (Typ) 363 and then Compile_Time_Known_Value (Expr)) 364 then 365 return; 366 end if; 367 368 -- Here we have a static predicate (note that it could have arisen from 369 -- an explicitly specified Dynamic_Predicate whose expression met the 370 -- rules for being predicate-static). If the expression is known at 371 -- compile time and obeys the predicate, then it is static and must be 372 -- labeled as such, which matters e.g. for case statements. The original 373 -- expression may be a type conversion of a variable with a known value, 374 -- which might otherwise not be marked static. 375 376 -- Case of real static predicate 377 378 if Is_Real_Type (Typ) then 379 if Real_Or_String_Static_Predicate_Matches 380 (Val => Make_Real_Literal (Sloc (Expr), Expr_Value_R (Expr)), 381 Typ => Typ) 382 then 383 Set_Is_Static_Expression (Expr); 384 return; 385 end if; 386 387 -- Case of string static predicate 388 389 elsif Is_String_Type (Typ) then 390 if Real_Or_String_Static_Predicate_Matches 391 (Val => Expr_Value_S (Expr), Typ => Typ) 392 then 393 Set_Is_Static_Expression (Expr); 394 return; 395 end if; 396 397 -- Case of discrete static predicate 398 399 else 400 pragma Assert (Is_Discrete_Type (Typ)); 401 402 -- If static predicate matches, nothing to do 403 404 if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then 405 Set_Is_Static_Expression (Expr); 406 return; 407 end if; 408 end if; 409 410 -- Here we know that the predicate will fail 411 412 -- Special case of static expression failing a predicate (other than one 413 -- that was explicitly specified with a Dynamic_Predicate aspect). If 414 -- the expression comes from a qualified_expression or type_conversion 415 -- this is an error (Static_Failure_Is_Error); otherwise we only issue 416 -- a warning and the expression is no longer considered static. 417 418 if Is_Static_Expression (Expr) 419 and then not Has_Dynamic_Predicate_Aspect (Typ) 420 then 421 if Static_Failure_Is_Error then 422 Error_Msg_NE 423 ("static expression fails static predicate check on &", 424 Expr, Typ); 425 426 else 427 Error_Msg_NE 428 ("??static expression fails static predicate check on &", 429 Expr, Typ); 430 Error_Msg_N 431 ("\??expression is no longer considered static", Expr); 432 433 Set_Is_Static_Expression (Expr, False); 434 end if; 435 436 -- In all other cases, this is just a warning that a test will fail. 437 -- It does not matter if the expression is static or not, or if the 438 -- predicate comes from a dynamic predicate aspect or not. 439 440 else 441 Error_Msg_NE 442 ("??expression fails predicate check on &", Expr, Typ); 443 444 -- Force a check here, which is potentially a redundant check, but 445 -- this ensures a check will be done in cases where the expression 446 -- is folded, and since this is definitely a failure, extra checks 447 -- are OK. 448 449 if Predicate_Enabled (Typ) then 450 Insert_Action (Expr, 451 Make_Predicate_Check 452 (Typ, Duplicate_Subexpr (Expr)), Suppress => All_Checks); 453 end if; 454 end if; 455 end Check_Expression_Against_Static_Predicate; 456 457 ------------------------------ 458 -- Check_Non_Static_Context -- 459 ------------------------------ 460 461 procedure Check_Non_Static_Context (N : Node_Id) is 462 T : constant Entity_Id := Etype (N); 463 Checks_On : constant Boolean := 464 not Index_Checks_Suppressed (T) 465 and not Range_Checks_Suppressed (T); 466 467 begin 468 -- Ignore cases of non-scalar types, error types, or universal real 469 -- types that have no usable bounds. 470 471 if T = Any_Type 472 or else not Is_Scalar_Type (T) 473 or else T = Universal_Fixed 474 or else T = Universal_Real 475 then 476 return; 477 end if; 478 479 -- At this stage we have a scalar type. If we have an expression that 480 -- raises CE, then we already issued a warning or error msg so there is 481 -- nothing more to be done in this routine. 482 483 if Raises_Constraint_Error (N) then 484 return; 485 end if; 486 487 -- Now we have a scalar type which is not marked as raising a constraint 488 -- error exception. The main purpose of this routine is to deal with 489 -- static expressions appearing in a non-static context. That means 490 -- that if we do not have a static expression then there is not much 491 -- to do. The one case that we deal with here is that if we have a 492 -- floating-point value that is out of range, then we post a warning 493 -- that an infinity will result. 494 495 if not Is_Static_Expression (N) then 496 if Is_Floating_Point_Type (T) then 497 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then 498 Error_Msg_N 499 ("??float value out of range, infinity will be generated", N); 500 501 -- The literal may be the result of constant-folding of a non- 502 -- static subexpression of a larger expression (e.g. a conversion 503 -- of a non-static variable whose value happens to be known). At 504 -- this point we must reduce the value of the subexpression to a 505 -- machine number (RM 4.9 (38/2)). 506 507 elsif Nkind (N) = N_Real_Literal 508 and then Nkind (Parent (N)) in N_Subexpr 509 then 510 Rewrite (N, New_Copy (N)); 511 Set_Realval 512 (N, Machine (Base_Type (T), Realval (N), Round_Even, N)); 513 end if; 514 end if; 515 516 return; 517 end if; 518 519 -- Here we have the case of outer level static expression of scalar 520 -- type, where the processing of this procedure is needed. 521 522 -- For real types, this is where we convert the value to a machine 523 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only 524 -- need to do this if the parent is a constant declaration, since in 525 -- other cases, gigi should do the necessary conversion correctly, but 526 -- experimentation shows that this is not the case on all machines, in 527 -- particular if we do not convert all literals to machine values in 528 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris 529 -- and SGI/Irix. 530 531 -- This conversion is always done by GNATprove on real literals in 532 -- non-static expressions, by calling Check_Non_Static_Context from 533 -- gnat2why, as GNATprove cannot do the conversion later contrary 534 -- to gigi. The frontend computes the information about which 535 -- expressions are static, which is used by gnat2why to call 536 -- Check_Non_Static_Context on exactly those real literals that are 537 -- not subexpressions of static expressions. 538 539 if Nkind (N) = N_Real_Literal 540 and then not Is_Machine_Number (N) 541 and then not Is_Generic_Type (Etype (N)) 542 and then Etype (N) /= Universal_Real 543 then 544 -- Check that value is in bounds before converting to machine 545 -- number, so as not to lose case where value overflows in the 546 -- least significant bit or less. See B490001. 547 548 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then 549 Out_Of_Range (N); 550 return; 551 end if; 552 553 -- Note: we have to copy the node, to avoid problems with conformance 554 -- of very similar numbers (see ACVC tests B4A010C and B63103A). 555 556 Rewrite (N, New_Copy (N)); 557 558 if not Is_Floating_Point_Type (T) then 559 Set_Realval 560 (N, Corresponding_Integer_Value (N) * Small_Value (T)); 561 562 elsif not UR_Is_Zero (Realval (N)) then 563 564 -- Note: even though RM 4.9(38) specifies biased rounding, this 565 -- has been modified by AI-100 in order to prevent confusing 566 -- differences in rounding between static and non-static 567 -- expressions. AI-100 specifies that the effect of such rounding 568 -- is implementation dependent, and in GNAT we round to nearest 569 -- even to match the run-time behavior. Note that this applies 570 -- to floating point literals, not fixed points ones, even though 571 -- their compiler representation is also as a universal real. 572 573 Set_Realval 574 (N, Machine (Base_Type (T), Realval (N), Round_Even, N)); 575 Set_Is_Machine_Number (N); 576 end if; 577 578 end if; 579 580 -- Check for out of range universal integer. This is a non-static 581 -- context, so the integer value must be in range of the runtime 582 -- representation of universal integers. 583 584 -- We do this only within an expression, because that is the only 585 -- case in which non-static universal integer values can occur, and 586 -- furthermore, Check_Non_Static_Context is currently (incorrectly???) 587 -- called in contexts like the expression of a number declaration where 588 -- we certainly want to allow out of range values. 589 590 -- We inhibit the warning when expansion is disabled, because the 591 -- preanalysis of a range of a 64-bit modular type may appear to 592 -- violate the constraint on non-static Universal_Integer. If there 593 -- is a true overflow it will be diagnosed during full analysis. 594 595 if Etype (N) = Universal_Integer 596 and then Nkind (N) = N_Integer_Literal 597 and then Nkind (Parent (N)) in N_Subexpr 598 and then Expander_Active 599 and then 600 (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer)) 601 or else 602 Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer))) 603 then 604 Apply_Compile_Time_Constraint_Error 605 (N, "non-static universal integer value out of range<<", 606 CE_Range_Check_Failed); 607 608 -- Check out of range of base type 609 610 elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then 611 Out_Of_Range (N); 612 613 -- Give a warning or error on the value outside the subtype. A warning 614 -- is omitted if the expression appears in a range that could be null 615 -- (warnings are handled elsewhere for this case). 616 617 elsif T /= Base_Type (T) and then Nkind (Parent (N)) /= N_Range then 618 if Is_In_Range (N, T, Assume_Valid => True) then 619 null; 620 621 elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then 622 -- Ignore out of range values for System.Priority in CodePeer 623 -- mode since the actual target compiler may provide a wider 624 -- range. 625 626 if CodePeer_Mode and then Is_RTE (T, RE_Priority) then 627 Set_Do_Range_Check (N, False); 628 629 -- Determine if the out-of-range violation constitutes a warning 630 -- or an error based on context, according to RM 4.9 (34/3). 631 632 elsif Nkind (Original_Node (N)) in 633 N_Type_Conversion | N_Qualified_Expression 634 and then Comes_From_Source (Original_Node (N)) 635 then 636 Apply_Compile_Time_Constraint_Error 637 (N, "value not in range of}", CE_Range_Check_Failed); 638 else 639 Apply_Compile_Time_Constraint_Error 640 (N, "value not in range of}<<", CE_Range_Check_Failed); 641 end if; 642 643 elsif Checks_On then 644 Enable_Range_Check (N); 645 646 else 647 Set_Do_Range_Check (N, False); 648 end if; 649 end if; 650 end Check_Non_Static_Context; 651 652 --------------------------------- 653 -- Check_String_Literal_Length -- 654 --------------------------------- 655 656 procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is 657 begin 658 if not Raises_Constraint_Error (N) and then Is_Constrained (Ttype) then 659 if UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype) 660 then 661 Apply_Compile_Time_Constraint_Error 662 (N, "string length wrong for}??", 663 CE_Length_Check_Failed, 664 Ent => Ttype, 665 Typ => Ttype); 666 end if; 667 end if; 668 end Check_String_Literal_Length; 669 670 -------------------------------------------- 671 -- Checking_Potentially_Static_Expression -- 672 -------------------------------------------- 673 674 function Checking_Potentially_Static_Expression return Boolean is 675 begin 676 return Checking_For_Potentially_Static_Expression; 677 end Checking_Potentially_Static_Expression; 678 679 -------------------- 680 -- Choice_Matches -- 681 -------------------- 682 683 function Choice_Matches 684 (Expr : Node_Id; 685 Choice : Node_Id) return Match_Result 686 is 687 Etyp : constant Entity_Id := Etype (Expr); 688 Val : Uint; 689 ValR : Ureal; 690 ValS : Node_Id; 691 692 begin 693 pragma Assert (Compile_Time_Known_Value (Expr)); 694 pragma Assert (Is_Scalar_Type (Etyp) or else Is_String_Type (Etyp)); 695 696 if not Is_OK_Static_Choice (Choice) then 697 Set_Raises_Constraint_Error (Choice); 698 return Non_Static; 699 700 -- When the choice denotes a subtype with a static predictate, check the 701 -- expression against the predicate values. Different procedures apply 702 -- to discrete and non-discrete types. 703 704 elsif (Nkind (Choice) = N_Subtype_Indication 705 or else (Is_Entity_Name (Choice) 706 and then Is_Type (Entity (Choice)))) 707 and then Has_Predicates (Etype (Choice)) 708 and then Has_Static_Predicate (Etype (Choice)) 709 then 710 if Is_Discrete_Type (Etype (Choice)) then 711 return 712 Choices_Match 713 (Expr, Static_Discrete_Predicate (Etype (Choice))); 714 715 elsif Real_Or_String_Static_Predicate_Matches (Expr, Etype (Choice)) 716 then 717 return Match; 718 719 else 720 return No_Match; 721 end if; 722 723 -- Discrete type case only 724 725 elsif Is_Discrete_Type (Etyp) then 726 Val := Expr_Value (Expr); 727 728 if Nkind (Choice) = N_Range then 729 if Val >= Expr_Value (Low_Bound (Choice)) 730 and then 731 Val <= Expr_Value (High_Bound (Choice)) 732 then 733 return Match; 734 else 735 return No_Match; 736 end if; 737 738 elsif Nkind (Choice) = N_Subtype_Indication 739 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) 740 then 741 if Val >= Expr_Value (Type_Low_Bound (Etype (Choice))) 742 and then 743 Val <= Expr_Value (Type_High_Bound (Etype (Choice))) 744 then 745 return Match; 746 else 747 return No_Match; 748 end if; 749 750 elsif Nkind (Choice) = N_Others_Choice then 751 return Match; 752 753 else 754 if Val = Expr_Value (Choice) then 755 return Match; 756 else 757 return No_Match; 758 end if; 759 end if; 760 761 -- Real type case 762 763 elsif Is_Real_Type (Etyp) then 764 ValR := Expr_Value_R (Expr); 765 766 if Nkind (Choice) = N_Range then 767 if ValR >= Expr_Value_R (Low_Bound (Choice)) 768 and then 769 ValR <= Expr_Value_R (High_Bound (Choice)) 770 then 771 return Match; 772 else 773 return No_Match; 774 end if; 775 776 elsif Nkind (Choice) = N_Subtype_Indication 777 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) 778 then 779 if ValR >= Expr_Value_R (Type_Low_Bound (Etype (Choice))) 780 and then 781 ValR <= Expr_Value_R (Type_High_Bound (Etype (Choice))) 782 then 783 return Match; 784 else 785 return No_Match; 786 end if; 787 788 else 789 if ValR = Expr_Value_R (Choice) then 790 return Match; 791 else 792 return No_Match; 793 end if; 794 end if; 795 796 -- String type cases 797 798 else 799 pragma Assert (Is_String_Type (Etyp)); 800 ValS := Expr_Value_S (Expr); 801 802 if Nkind (Choice) = N_Subtype_Indication 803 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) 804 then 805 if not Is_Constrained (Etype (Choice)) then 806 return Match; 807 808 else 809 declare 810 Typlen : constant Uint := 811 String_Type_Len (Etype (Choice)); 812 Strlen : constant Uint := 813 UI_From_Int (String_Length (Strval (ValS))); 814 begin 815 if Typlen = Strlen then 816 return Match; 817 else 818 return No_Match; 819 end if; 820 end; 821 end if; 822 823 else 824 if String_Equal (Strval (ValS), Strval (Expr_Value_S (Choice))) 825 then 826 return Match; 827 else 828 return No_Match; 829 end if; 830 end if; 831 end if; 832 end Choice_Matches; 833 834 ------------------- 835 -- Choices_Match -- 836 ------------------- 837 838 function Choices_Match 839 (Expr : Node_Id; 840 Choices : List_Id) return Match_Result 841 is 842 Choice : Node_Id; 843 Result : Match_Result; 844 845 begin 846 Choice := First (Choices); 847 while Present (Choice) loop 848 Result := Choice_Matches (Expr, Choice); 849 850 if Result /= No_Match then 851 return Result; 852 end if; 853 854 Next (Choice); 855 end loop; 856 857 return No_Match; 858 end Choices_Match; 859 860 -------------------------- 861 -- Compile_Time_Compare -- 862 -------------------------- 863 864 function Compile_Time_Compare 865 (L, R : Node_Id; 866 Assume_Valid : Boolean) return Compare_Result 867 is 868 Discard : aliased Uint; 869 begin 870 return Compile_Time_Compare (L, R, Discard'Access, Assume_Valid); 871 end Compile_Time_Compare; 872 873 function Compile_Time_Compare 874 (L, R : Node_Id; 875 Diff : access Uint; 876 Assume_Valid : Boolean; 877 Rec : Boolean := False) return Compare_Result 878 is 879 Ltyp : Entity_Id := Etype (L); 880 Rtyp : Entity_Id := Etype (R); 881 882 Discard : aliased Uint; 883 884 procedure Compare_Decompose 885 (N : Node_Id; 886 R : out Node_Id; 887 V : out Uint); 888 -- This procedure decomposes the node N into an expression node and a 889 -- signed offset, so that the value of N is equal to the value of R plus 890 -- the value V (which may be negative). If no such decomposition is 891 -- possible, then on return R is a copy of N, and V is set to zero. 892 893 function Compare_Fixup (N : Node_Id) return Node_Id; 894 -- This function deals with replacing 'Last and 'First references with 895 -- their corresponding type bounds, which we then can compare. The 896 -- argument is the original node, the result is the identity, unless we 897 -- have a 'Last/'First reference in which case the value returned is the 898 -- appropriate type bound. 899 900 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean; 901 -- Even if the context does not assume that values are valid, some 902 -- simple cases can be recognized. 903 904 function Is_Same_Value (L, R : Node_Id) return Boolean; 905 -- Returns True iff L and R represent expressions that definitely have 906 -- identical (but not necessarily compile-time-known) values Indeed the 907 -- caller is expected to have already dealt with the cases of compile 908 -- time known values, so these are not tested here. 909 910 ----------------------- 911 -- Compare_Decompose -- 912 ----------------------- 913 914 procedure Compare_Decompose 915 (N : Node_Id; 916 R : out Node_Id; 917 V : out Uint) 918 is 919 begin 920 if Nkind (N) = N_Op_Add 921 and then Nkind (Right_Opnd (N)) = N_Integer_Literal 922 then 923 R := Left_Opnd (N); 924 V := Intval (Right_Opnd (N)); 925 return; 926 927 elsif Nkind (N) = N_Op_Subtract 928 and then Nkind (Right_Opnd (N)) = N_Integer_Literal 929 then 930 R := Left_Opnd (N); 931 V := UI_Negate (Intval (Right_Opnd (N))); 932 return; 933 934 elsif Nkind (N) = N_Attribute_Reference then 935 if Attribute_Name (N) = Name_Succ then 936 R := First (Expressions (N)); 937 V := Uint_1; 938 return; 939 940 elsif Attribute_Name (N) = Name_Pred then 941 R := First (Expressions (N)); 942 V := Uint_Minus_1; 943 return; 944 end if; 945 end if; 946 947 R := N; 948 V := Uint_0; 949 end Compare_Decompose; 950 951 ------------------- 952 -- Compare_Fixup -- 953 ------------------- 954 955 function Compare_Fixup (N : Node_Id) return Node_Id is 956 Indx : Node_Id; 957 Xtyp : Entity_Id; 958 Subs : Nat; 959 960 begin 961 -- Fixup only required for First/Last attribute reference 962 963 if Nkind (N) = N_Attribute_Reference 964 and then Attribute_Name (N) in Name_First | Name_Last 965 then 966 Xtyp := Etype (Prefix (N)); 967 968 -- If we have no type, then just abandon the attempt to do 969 -- a fixup, this is probably the result of some other error. 970 971 if No (Xtyp) then 972 return N; 973 end if; 974 975 -- Dereference an access type 976 977 if Is_Access_Type (Xtyp) then 978 Xtyp := Designated_Type (Xtyp); 979 end if; 980 981 -- If we don't have an array type at this stage, something is 982 -- peculiar, e.g. another error, and we abandon the attempt at 983 -- a fixup. 984 985 if not Is_Array_Type (Xtyp) then 986 return N; 987 end if; 988 989 -- Ignore unconstrained array, since bounds are not meaningful 990 991 if not Is_Constrained (Xtyp) then 992 return N; 993 end if; 994 995 if Ekind (Xtyp) = E_String_Literal_Subtype then 996 if Attribute_Name (N) = Name_First then 997 return String_Literal_Low_Bound (Xtyp); 998 else 999 return 1000 Make_Integer_Literal (Sloc (N), 1001 Intval => Intval (String_Literal_Low_Bound (Xtyp)) + 1002 String_Literal_Length (Xtyp)); 1003 end if; 1004 end if; 1005 1006 -- Find correct index type 1007 1008 Indx := First_Index (Xtyp); 1009 1010 if Present (Expressions (N)) then 1011 Subs := UI_To_Int (Expr_Value (First (Expressions (N)))); 1012 1013 for J in 2 .. Subs loop 1014 Next_Index (Indx); 1015 end loop; 1016 end if; 1017 1018 Xtyp := Etype (Indx); 1019 1020 if Attribute_Name (N) = Name_First then 1021 return Type_Low_Bound (Xtyp); 1022 else 1023 return Type_High_Bound (Xtyp); 1024 end if; 1025 end if; 1026 1027 return N; 1028 end Compare_Fixup; 1029 1030 ---------------------------- 1031 -- Is_Known_Valid_Operand -- 1032 ---------------------------- 1033 1034 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean is 1035 begin 1036 return (Is_Entity_Name (Opnd) 1037 and then 1038 (Is_Known_Valid (Entity (Opnd)) 1039 or else Ekind (Entity (Opnd)) = E_In_Parameter 1040 or else 1041 (Is_Object (Entity (Opnd)) 1042 and then Present (Current_Value (Entity (Opnd)))))) 1043 or else Is_OK_Static_Expression (Opnd); 1044 end Is_Known_Valid_Operand; 1045 1046 ------------------- 1047 -- Is_Same_Value -- 1048 ------------------- 1049 1050 function Is_Same_Value (L, R : Node_Id) return Boolean is 1051 Lf : constant Node_Id := Compare_Fixup (L); 1052 Rf : constant Node_Id := Compare_Fixup (R); 1053 1054 function Is_Rewritten_Loop_Entry (N : Node_Id) return Boolean; 1055 -- An attribute reference to Loop_Entry may have been rewritten into 1056 -- its prefix as a way to avoid generating a constant for that 1057 -- attribute when the corresponding pragma is ignored. These nodes 1058 -- should be ignored when deciding if they can be equal to one 1059 -- another. 1060 1061 function Is_Same_Subscript (L, R : List_Id) return Boolean; 1062 -- L, R are the Expressions values from two attribute nodes for First 1063 -- or Last attributes. Either may be set to No_List if no expressions 1064 -- are present (indicating subscript 1). The result is True if both 1065 -- expressions represent the same subscript (note one case is where 1066 -- one subscript is missing and the other is explicitly set to 1). 1067 1068 ----------------------------- 1069 -- Is_Rewritten_Loop_Entry -- 1070 ----------------------------- 1071 1072 function Is_Rewritten_Loop_Entry (N : Node_Id) return Boolean is 1073 Orig_N : constant Node_Id := Original_Node (N); 1074 begin 1075 return Orig_N /= N 1076 and then Nkind (Orig_N) = N_Attribute_Reference 1077 and then Get_Attribute_Id (Attribute_Name (Orig_N)) = 1078 Attribute_Loop_Entry; 1079 end Is_Rewritten_Loop_Entry; 1080 1081 ----------------------- 1082 -- Is_Same_Subscript -- 1083 ----------------------- 1084 1085 function Is_Same_Subscript (L, R : List_Id) return Boolean is 1086 begin 1087 if L = No_List then 1088 if R = No_List then 1089 return True; 1090 else 1091 return Expr_Value (First (R)) = Uint_1; 1092 end if; 1093 1094 else 1095 if R = No_List then 1096 return Expr_Value (First (L)) = Uint_1; 1097 else 1098 return Expr_Value (First (L)) = Expr_Value (First (R)); 1099 end if; 1100 end if; 1101 end Is_Same_Subscript; 1102 1103 -- Start of processing for Is_Same_Value 1104 1105 begin 1106 -- Loop_Entry nodes rewritten into their prefix inside ignored 1107 -- pragmas should never lead to a decision of equality. 1108 1109 if Is_Rewritten_Loop_Entry (Lf) 1110 or else Is_Rewritten_Loop_Entry (Rf) 1111 then 1112 return False; 1113 1114 -- Values are the same if they refer to the same entity and the 1115 -- entity is nonvolatile. 1116 1117 elsif Nkind (Lf) in N_Identifier | N_Expanded_Name 1118 and then Nkind (Rf) in N_Identifier | N_Expanded_Name 1119 and then Entity (Lf) = Entity (Rf) 1120 1121 -- If the entity is a discriminant, the two expressions may be 1122 -- bounds of components of objects of the same discriminated type. 1123 -- The values of the discriminants are not static, and therefore 1124 -- the result is unknown. 1125 1126 and then Ekind (Entity (Lf)) /= E_Discriminant 1127 and then Present (Entity (Lf)) 1128 1129 -- This does not however apply to Float types, since we may have 1130 -- two NaN values and they should never compare equal. 1131 1132 and then not Is_Floating_Point_Type (Etype (L)) 1133 and then not Is_Volatile_Reference (L) 1134 and then not Is_Volatile_Reference (R) 1135 then 1136 return True; 1137 1138 -- Or if they are compile-time-known and identical 1139 1140 elsif Compile_Time_Known_Value (Lf) 1141 and then 1142 Compile_Time_Known_Value (Rf) 1143 and then Expr_Value (Lf) = Expr_Value (Rf) 1144 then 1145 return True; 1146 1147 -- False if Nkind of the two nodes is different for remaining cases 1148 1149 elsif Nkind (Lf) /= Nkind (Rf) then 1150 return False; 1151 1152 -- True if both 'First or 'Last values applying to the same entity 1153 -- (first and last don't change even if value does). Note that we 1154 -- need this even with the calls to Compare_Fixup, to handle the 1155 -- case of unconstrained array attributes where Compare_Fixup 1156 -- cannot find useful bounds. 1157 1158 elsif Nkind (Lf) = N_Attribute_Reference 1159 and then Attribute_Name (Lf) = Attribute_Name (Rf) 1160 and then Attribute_Name (Lf) in Name_First | Name_Last 1161 and then Nkind (Prefix (Lf)) in N_Identifier | N_Expanded_Name 1162 and then Nkind (Prefix (Rf)) in N_Identifier | N_Expanded_Name 1163 and then Entity (Prefix (Lf)) = Entity (Prefix (Rf)) 1164 and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf)) 1165 then 1166 return True; 1167 1168 -- True if the same selected component from the same record 1169 1170 elsif Nkind (Lf) = N_Selected_Component 1171 and then Selector_Name (Lf) = Selector_Name (Rf) 1172 and then Is_Same_Value (Prefix (Lf), Prefix (Rf)) 1173 then 1174 return True; 1175 1176 -- True if the same unary operator applied to the same operand 1177 1178 elsif Nkind (Lf) in N_Unary_Op 1179 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf)) 1180 then 1181 return True; 1182 1183 -- True if the same binary operator applied to the same operands 1184 1185 elsif Nkind (Lf) in N_Binary_Op 1186 and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf)) 1187 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf)) 1188 then 1189 return True; 1190 1191 -- All other cases, we can't tell, so return False 1192 1193 else 1194 return False; 1195 end if; 1196 end Is_Same_Value; 1197 1198 -- Start of processing for Compile_Time_Compare 1199 1200 begin 1201 Diff.all := No_Uint; 1202 1203 -- In preanalysis mode, always return Unknown unless the expression 1204 -- is static. It is too early to be thinking we know the result of a 1205 -- comparison, save that judgment for the full analysis. This is 1206 -- particularly important in the case of pre and postconditions, which 1207 -- otherwise can be prematurely collapsed into having True or False 1208 -- conditions when this is inappropriate. 1209 1210 if not (Full_Analysis 1211 or else (Is_OK_Static_Expression (L) 1212 and then 1213 Is_OK_Static_Expression (R))) 1214 then 1215 return Unknown; 1216 end if; 1217 1218 -- If either operand could raise Constraint_Error, then we cannot 1219 -- know the result at compile time (since CE may be raised). 1220 1221 if not (Cannot_Raise_Constraint_Error (L) 1222 and then 1223 Cannot_Raise_Constraint_Error (R)) 1224 then 1225 return Unknown; 1226 end if; 1227 1228 -- Identical operands are most certainly equal 1229 1230 if L = R then 1231 return EQ; 1232 end if; 1233 1234 -- If expressions have no types, then do not attempt to determine if 1235 -- they are the same, since something funny is going on. One case in 1236 -- which this happens is during generic template analysis, when bounds 1237 -- are not fully analyzed. 1238 1239 if No (Ltyp) or else No (Rtyp) then 1240 return Unknown; 1241 end if; 1242 1243 -- These get reset to the base type for the case of entities where 1244 -- Is_Known_Valid is not set. This takes care of handling possible 1245 -- invalid representations using the value of the base type, in 1246 -- accordance with RM 13.9.1(10). 1247 1248 Ltyp := Underlying_Type (Ltyp); 1249 Rtyp := Underlying_Type (Rtyp); 1250 1251 -- Same rationale as above, but for Underlying_Type instead of Etype 1252 1253 if No (Ltyp) or else No (Rtyp) then 1254 return Unknown; 1255 end if; 1256 1257 -- We do not attempt comparisons for packed arrays represented as 1258 -- modular types, where the semantics of comparison is quite different. 1259 1260 if Is_Packed_Array_Impl_Type (Ltyp) 1261 and then Is_Modular_Integer_Type (Ltyp) 1262 then 1263 return Unknown; 1264 1265 -- For access types, the only time we know the result at compile time 1266 -- (apart from identical operands, which we handled already) is if we 1267 -- know one operand is null and the other is not, or both operands are 1268 -- known null. 1269 1270 elsif Is_Access_Type (Ltyp) then 1271 if Known_Null (L) then 1272 if Known_Null (R) then 1273 return EQ; 1274 elsif Known_Non_Null (R) then 1275 return NE; 1276 else 1277 return Unknown; 1278 end if; 1279 1280 elsif Known_Non_Null (L) and then Known_Null (R) then 1281 return NE; 1282 1283 else 1284 return Unknown; 1285 end if; 1286 1287 -- Case where comparison involves two compile-time-known values 1288 1289 elsif Compile_Time_Known_Value (L) 1290 and then 1291 Compile_Time_Known_Value (R) 1292 then 1293 -- For the floating-point case, we have to be a little careful, since 1294 -- at compile time we are dealing with universal exact values, but at 1295 -- runtime, these will be in non-exact target form. That's why the 1296 -- returned results are LE and GE below instead of LT and GT. 1297 1298 if Is_Floating_Point_Type (Ltyp) 1299 or else 1300 Is_Floating_Point_Type (Rtyp) 1301 then 1302 declare 1303 Lo : constant Ureal := Expr_Value_R (L); 1304 Hi : constant Ureal := Expr_Value_R (R); 1305 begin 1306 if Lo < Hi then 1307 return LE; 1308 elsif Lo = Hi then 1309 return EQ; 1310 else 1311 return GE; 1312 end if; 1313 end; 1314 1315 -- For string types, we have two string literals and we proceed to 1316 -- compare them using the Ada style dictionary string comparison. 1317 1318 elsif not Is_Scalar_Type (Ltyp) then 1319 declare 1320 Lstring : constant String_Id := Strval (Expr_Value_S (L)); 1321 Rstring : constant String_Id := Strval (Expr_Value_S (R)); 1322 Llen : constant Nat := String_Length (Lstring); 1323 Rlen : constant Nat := String_Length (Rstring); 1324 1325 begin 1326 for J in 1 .. Nat'Min (Llen, Rlen) loop 1327 declare 1328 LC : constant Char_Code := Get_String_Char (Lstring, J); 1329 RC : constant Char_Code := Get_String_Char (Rstring, J); 1330 begin 1331 if LC < RC then 1332 return LT; 1333 elsif LC > RC then 1334 return GT; 1335 end if; 1336 end; 1337 end loop; 1338 1339 if Llen < Rlen then 1340 return LT; 1341 elsif Llen > Rlen then 1342 return GT; 1343 else 1344 return EQ; 1345 end if; 1346 end; 1347 1348 -- For remaining scalar cases we know exactly (note that this does 1349 -- include the fixed-point case, where we know the run time integer 1350 -- values now). 1351 1352 else 1353 declare 1354 Lo : constant Uint := Expr_Value (L); 1355 Hi : constant Uint := Expr_Value (R); 1356 begin 1357 if Lo < Hi then 1358 Diff.all := Hi - Lo; 1359 return LT; 1360 elsif Lo = Hi then 1361 return EQ; 1362 else 1363 Diff.all := Lo - Hi; 1364 return GT; 1365 end if; 1366 end; 1367 end if; 1368 1369 -- Cases where at least one operand is not known at compile time 1370 1371 else 1372 -- Remaining checks apply only for discrete types 1373 1374 if not Is_Discrete_Type (Ltyp) 1375 or else 1376 not Is_Discrete_Type (Rtyp) 1377 then 1378 return Unknown; 1379 end if; 1380 1381 -- Defend against generic types, or actually any expressions that 1382 -- contain a reference to a generic type from within a generic 1383 -- template. We don't want to do any range analysis of such 1384 -- expressions for two reasons. First, the bounds of a generic type 1385 -- itself are junk and cannot be used for any kind of analysis. 1386 -- Second, we may have a case where the range at run time is indeed 1387 -- known, but we don't want to do compile time analysis in the 1388 -- template based on that range since in an instance the value may be 1389 -- static, and able to be elaborated without reference to the bounds 1390 -- of types involved. As an example, consider: 1391 1392 -- (F'Pos (F'Last) + 1) > Integer'Last 1393 1394 -- The expression on the left side of > is Universal_Integer and thus 1395 -- acquires the type Integer for evaluation at run time, and at run 1396 -- time it is true that this condition is always False, but within 1397 -- an instance F may be a type with a static range greater than the 1398 -- range of Integer, and the expression statically evaluates to True. 1399 1400 if References_Generic_Formal_Type (L) 1401 or else 1402 References_Generic_Formal_Type (R) 1403 then 1404 return Unknown; 1405 end if; 1406 1407 -- Replace types by base types for the case of values which are not 1408 -- known to have valid representations. This takes care of properly 1409 -- dealing with invalid representations. 1410 1411 if not Assume_Valid then 1412 if not (Is_Entity_Name (L) 1413 and then (Is_Known_Valid (Entity (L)) 1414 or else Assume_No_Invalid_Values)) 1415 then 1416 Ltyp := Underlying_Type (Base_Type (Ltyp)); 1417 end if; 1418 1419 if not (Is_Entity_Name (R) 1420 and then (Is_Known_Valid (Entity (R)) 1421 or else Assume_No_Invalid_Values)) 1422 then 1423 Rtyp := Underlying_Type (Base_Type (Rtyp)); 1424 end if; 1425 end if; 1426 1427 -- First attempt is to decompose the expressions to extract a 1428 -- constant offset resulting from the use of any of the forms: 1429 1430 -- expr + literal 1431 -- expr - literal 1432 -- typ'Succ (expr) 1433 -- typ'Pred (expr) 1434 1435 -- Then we see if the two expressions are the same value, and if so 1436 -- the result is obtained by comparing the offsets. 1437 1438 -- Note: the reason we do this test first is that it returns only 1439 -- decisive results (with diff set), where other tests, like the 1440 -- range test, may not be as so decisive. Consider for example 1441 -- J .. J + 1. This code can conclude LT with a difference of 1, 1442 -- even if the range of J is not known. 1443 1444 declare 1445 Lnode : Node_Id; 1446 Loffs : Uint; 1447 Rnode : Node_Id; 1448 Roffs : Uint; 1449 1450 begin 1451 Compare_Decompose (L, Lnode, Loffs); 1452 Compare_Decompose (R, Rnode, Roffs); 1453 1454 if Is_Same_Value (Lnode, Rnode) then 1455 if Loffs = Roffs then 1456 return EQ; 1457 end if; 1458 1459 -- When the offsets are not equal, we can go farther only if 1460 -- the types are not modular (e.g. X < X + 1 is False if X is 1461 -- the largest number). 1462 1463 if not Is_Modular_Integer_Type (Ltyp) 1464 and then not Is_Modular_Integer_Type (Rtyp) 1465 then 1466 if Loffs < Roffs then 1467 Diff.all := Roffs - Loffs; 1468 return LT; 1469 else 1470 Diff.all := Loffs - Roffs; 1471 return GT; 1472 end if; 1473 end if; 1474 end if; 1475 end; 1476 1477 -- Next, try range analysis and see if operand ranges are disjoint 1478 1479 declare 1480 LOK, ROK : Boolean; 1481 LLo, LHi : Uint; 1482 RLo, RHi : Uint; 1483 1484 Single : Boolean; 1485 -- True if each range is a single point 1486 1487 begin 1488 Determine_Range (L, LOK, LLo, LHi, Assume_Valid); 1489 Determine_Range (R, ROK, RLo, RHi, Assume_Valid); 1490 1491 if LOK and ROK then 1492 Single := (LLo = LHi) and then (RLo = RHi); 1493 1494 if LHi < RLo then 1495 if Single and Assume_Valid then 1496 Diff.all := RLo - LLo; 1497 end if; 1498 1499 return LT; 1500 1501 elsif RHi < LLo then 1502 if Single and Assume_Valid then 1503 Diff.all := LLo - RLo; 1504 end if; 1505 1506 return GT; 1507 1508 elsif Single and then LLo = RLo then 1509 1510 -- If the range includes a single literal and we can assume 1511 -- validity then the result is known even if an operand is 1512 -- not static. 1513 1514 if Assume_Valid then 1515 return EQ; 1516 else 1517 return Unknown; 1518 end if; 1519 1520 elsif LHi = RLo then 1521 return LE; 1522 1523 elsif RHi = LLo then 1524 return GE; 1525 1526 elsif not Is_Known_Valid_Operand (L) 1527 and then not Assume_Valid 1528 then 1529 if Is_Same_Value (L, R) then 1530 return EQ; 1531 else 1532 return Unknown; 1533 end if; 1534 end if; 1535 1536 -- If the range of either operand cannot be determined, nothing 1537 -- further can be inferred. 1538 1539 else 1540 return Unknown; 1541 end if; 1542 end; 1543 1544 -- Here is where we check for comparisons against maximum bounds of 1545 -- types, where we know that no value can be outside the bounds of 1546 -- the subtype. Note that this routine is allowed to assume that all 1547 -- expressions are within their subtype bounds. Callers wishing to 1548 -- deal with possibly invalid values must in any case take special 1549 -- steps (e.g. conversions to larger types) to avoid this kind of 1550 -- optimization, which is always considered to be valid. We do not 1551 -- attempt this optimization with generic types, since the type 1552 -- bounds may not be meaningful in this case. 1553 1554 -- We are in danger of an infinite recursion here. It does not seem 1555 -- useful to go more than one level deep, so the parameter Rec is 1556 -- used to protect ourselves against this infinite recursion. 1557 1558 if not Rec then 1559 1560 -- See if we can get a decisive check against one operand and a 1561 -- bound of the other operand (four possible tests here). Note 1562 -- that we avoid testing junk bounds of a generic type. 1563 1564 if not Is_Generic_Type (Rtyp) then 1565 case Compile_Time_Compare (L, Type_Low_Bound (Rtyp), 1566 Discard'Access, 1567 Assume_Valid, Rec => True) 1568 is 1569 when LT => return LT; 1570 when LE => return LE; 1571 when EQ => return LE; 1572 when others => null; 1573 end case; 1574 1575 case Compile_Time_Compare (L, Type_High_Bound (Rtyp), 1576 Discard'Access, 1577 Assume_Valid, Rec => True) 1578 is 1579 when GT => return GT; 1580 when GE => return GE; 1581 when EQ => return GE; 1582 when others => null; 1583 end case; 1584 end if; 1585 1586 if not Is_Generic_Type (Ltyp) then 1587 case Compile_Time_Compare (Type_Low_Bound (Ltyp), R, 1588 Discard'Access, 1589 Assume_Valid, Rec => True) 1590 is 1591 when GT => return GT; 1592 when GE => return GE; 1593 when EQ => return GE; 1594 when others => null; 1595 end case; 1596 1597 case Compile_Time_Compare (Type_High_Bound (Ltyp), R, 1598 Discard'Access, 1599 Assume_Valid, Rec => True) 1600 is 1601 when LT => return LT; 1602 when LE => return LE; 1603 when EQ => return LE; 1604 when others => null; 1605 end case; 1606 end if; 1607 end if; 1608 1609 -- Next attempt is to see if we have an entity compared with a 1610 -- compile-time-known value, where there is a current value 1611 -- conditional for the entity which can tell us the result. 1612 1613 declare 1614 Var : Node_Id; 1615 -- Entity variable (left operand) 1616 1617 Val : Uint; 1618 -- Value (right operand) 1619 1620 Inv : Boolean; 1621 -- If False, we have reversed the operands 1622 1623 Op : Node_Kind; 1624 -- Comparison operator kind from Get_Current_Value_Condition call 1625 1626 Opn : Node_Id; 1627 -- Value from Get_Current_Value_Condition call 1628 1629 Opv : Uint; 1630 -- Value of Opn 1631 1632 Result : Compare_Result; 1633 -- Known result before inversion 1634 1635 begin 1636 if Is_Entity_Name (L) 1637 and then Compile_Time_Known_Value (R) 1638 then 1639 Var := L; 1640 Val := Expr_Value (R); 1641 Inv := False; 1642 1643 elsif Is_Entity_Name (R) 1644 and then Compile_Time_Known_Value (L) 1645 then 1646 Var := R; 1647 Val := Expr_Value (L); 1648 Inv := True; 1649 1650 -- That was the last chance at finding a compile time result 1651 1652 else 1653 return Unknown; 1654 end if; 1655 1656 Get_Current_Value_Condition (Var, Op, Opn); 1657 1658 -- That was the last chance, so if we got nothing return 1659 1660 if No (Opn) then 1661 return Unknown; 1662 end if; 1663 1664 Opv := Expr_Value (Opn); 1665 1666 -- We got a comparison, so we might have something interesting 1667 1668 -- Convert LE to LT and GE to GT, just so we have fewer cases 1669 1670 if Op = N_Op_Le then 1671 Op := N_Op_Lt; 1672 Opv := Opv + 1; 1673 1674 elsif Op = N_Op_Ge then 1675 Op := N_Op_Gt; 1676 Opv := Opv - 1; 1677 end if; 1678 1679 -- Deal with equality case 1680 1681 if Op = N_Op_Eq then 1682 if Val = Opv then 1683 Result := EQ; 1684 elsif Opv < Val then 1685 Result := LT; 1686 else 1687 Result := GT; 1688 end if; 1689 1690 -- Deal with inequality case 1691 1692 elsif Op = N_Op_Ne then 1693 if Val = Opv then 1694 Result := NE; 1695 else 1696 return Unknown; 1697 end if; 1698 1699 -- Deal with greater than case 1700 1701 elsif Op = N_Op_Gt then 1702 if Opv >= Val then 1703 Result := GT; 1704 elsif Opv = Val - 1 then 1705 Result := GE; 1706 else 1707 return Unknown; 1708 end if; 1709 1710 -- Deal with less than case 1711 1712 else pragma Assert (Op = N_Op_Lt); 1713 if Opv <= Val then 1714 Result := LT; 1715 elsif Opv = Val + 1 then 1716 Result := LE; 1717 else 1718 return Unknown; 1719 end if; 1720 end if; 1721 1722 -- Deal with inverting result 1723 1724 if Inv then 1725 case Result is 1726 when GT => return LT; 1727 when GE => return LE; 1728 when LT => return GT; 1729 when LE => return GE; 1730 when others => return Result; 1731 end case; 1732 end if; 1733 1734 return Result; 1735 end; 1736 end if; 1737 end Compile_Time_Compare; 1738 1739 ------------------------------- 1740 -- Compile_Time_Known_Bounds -- 1741 ------------------------------- 1742 1743 function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is 1744 Indx : Node_Id; 1745 Typ : Entity_Id; 1746 1747 begin 1748 if T = Any_Composite or else not Is_Array_Type (T) then 1749 return False; 1750 end if; 1751 1752 Indx := First_Index (T); 1753 while Present (Indx) loop 1754 Typ := Underlying_Type (Etype (Indx)); 1755 1756 -- Never look at junk bounds of a generic type 1757 1758 if Is_Generic_Type (Typ) then 1759 return False; 1760 end if; 1761 1762 -- Otherwise check bounds for compile-time-known 1763 1764 if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then 1765 return False; 1766 elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then 1767 return False; 1768 else 1769 Next_Index (Indx); 1770 end if; 1771 end loop; 1772 1773 return True; 1774 end Compile_Time_Known_Bounds; 1775 1776 ------------------------------ 1777 -- Compile_Time_Known_Value -- 1778 ------------------------------ 1779 1780 function Compile_Time_Known_Value (Op : Node_Id) return Boolean is 1781 K : constant Node_Kind := Nkind (Op); 1782 CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size); 1783 1784 begin 1785 -- Never known at compile time if bad type or raises Constraint_Error 1786 -- or empty (latter case occurs only as a result of a previous error). 1787 1788 if No (Op) then 1789 Check_Error_Detected; 1790 return False; 1791 1792 elsif Op = Error 1793 or else Etype (Op) = Any_Type 1794 or else Raises_Constraint_Error (Op) 1795 then 1796 return False; 1797 end if; 1798 1799 -- If we have an entity name, then see if it is the name of a constant 1800 -- and if so, test the corresponding constant value, or the name of an 1801 -- enumeration literal, which is always a constant. 1802 1803 if Present (Etype (Op)) and then Is_Entity_Name (Op) then 1804 declare 1805 Ent : constant Entity_Id := Entity (Op); 1806 Val : Node_Id; 1807 1808 begin 1809 -- Never known at compile time if it is a packed array value. We 1810 -- might want to try to evaluate these at compile time one day, 1811 -- but we do not make that attempt now. 1812 1813 if Is_Packed_Array_Impl_Type (Etype (Op)) then 1814 return False; 1815 1816 elsif Ekind (Ent) = E_Enumeration_Literal then 1817 return True; 1818 1819 elsif Ekind (Ent) = E_Constant then 1820 Val := Constant_Value (Ent); 1821 1822 if Present (Val) then 1823 1824 -- Guard against an illegal deferred constant whose full 1825 -- view is initialized with a reference to itself. Treat 1826 -- this case as a value not known at compile time. 1827 1828 if Is_Entity_Name (Val) and then Entity (Val) = Ent then 1829 return False; 1830 else 1831 return Compile_Time_Known_Value (Val); 1832 end if; 1833 1834 -- Otherwise, the constant does not have a compile-time-known 1835 -- value. 1836 1837 else 1838 return False; 1839 end if; 1840 end if; 1841 end; 1842 1843 -- We have a value, see if it is compile-time-known 1844 1845 else 1846 -- Integer literals are worth storing in the cache 1847 1848 if K = N_Integer_Literal then 1849 CV_Ent.N := Op; 1850 CV_Ent.V := Intval (Op); 1851 return True; 1852 1853 -- Other literals and NULL are known at compile time 1854 1855 elsif K in 1856 N_Character_Literal | N_Real_Literal | N_String_Literal | N_Null 1857 then 1858 return True; 1859 1860 -- Evaluate static discriminants, to eliminate dead paths and 1861 -- redundant discriminant checks. 1862 1863 elsif Is_Static_Discriminant_Component (Op) then 1864 return True; 1865 end if; 1866 end if; 1867 1868 -- If we fall through, not known at compile time 1869 1870 return False; 1871 1872 -- If we get an exception while trying to do this test, then some error 1873 -- has occurred, and we simply say that the value is not known after all 1874 1875 exception 1876 when others => 1877 -- With debug flag K we will get an exception unless an error has 1878 -- already occurred (useful for debugging). 1879 1880 if Debug_Flag_K then 1881 Check_Error_Detected; 1882 end if; 1883 1884 return False; 1885 end Compile_Time_Known_Value; 1886 1887 -------------------------------------- 1888 -- Compile_Time_Known_Value_Or_Aggr -- 1889 -------------------------------------- 1890 1891 function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is 1892 begin 1893 -- If we have an entity name, then see if it is the name of a constant 1894 -- and if so, test the corresponding constant value, or the name of 1895 -- an enumeration literal, which is always a constant. 1896 1897 if Is_Entity_Name (Op) then 1898 declare 1899 E : constant Entity_Id := Entity (Op); 1900 V : Node_Id; 1901 1902 begin 1903 if Ekind (E) = E_Enumeration_Literal then 1904 return True; 1905 1906 elsif Ekind (E) /= E_Constant then 1907 return False; 1908 1909 else 1910 V := Constant_Value (E); 1911 return Present (V) 1912 and then Compile_Time_Known_Value_Or_Aggr (V); 1913 end if; 1914 end; 1915 1916 -- We have a value, see if it is compile-time-known 1917 1918 else 1919 if Compile_Time_Known_Value (Op) then 1920 return True; 1921 1922 elsif Nkind (Op) = N_Aggregate then 1923 1924 if Present (Expressions (Op)) then 1925 declare 1926 Expr : Node_Id; 1927 begin 1928 Expr := First (Expressions (Op)); 1929 while Present (Expr) loop 1930 if not Compile_Time_Known_Value_Or_Aggr (Expr) then 1931 return False; 1932 else 1933 Next (Expr); 1934 end if; 1935 end loop; 1936 end; 1937 end if; 1938 1939 if Present (Component_Associations (Op)) then 1940 declare 1941 Cass : Node_Id; 1942 1943 begin 1944 Cass := First (Component_Associations (Op)); 1945 while Present (Cass) loop 1946 if not 1947 Compile_Time_Known_Value_Or_Aggr (Expression (Cass)) 1948 then 1949 return False; 1950 end if; 1951 1952 Next (Cass); 1953 end loop; 1954 end; 1955 end if; 1956 1957 return True; 1958 1959 elsif Nkind (Op) = N_Qualified_Expression then 1960 return Compile_Time_Known_Value_Or_Aggr (Expression (Op)); 1961 1962 -- All other types of values are not known at compile time 1963 1964 else 1965 return False; 1966 end if; 1967 1968 end if; 1969 end Compile_Time_Known_Value_Or_Aggr; 1970 1971 --------------------------------------- 1972 -- CRT_Safe_Compile_Time_Known_Value -- 1973 --------------------------------------- 1974 1975 function CRT_Safe_Compile_Time_Known_Value (Op : Node_Id) return Boolean is 1976 begin 1977 if (Configurable_Run_Time_Mode or No_Run_Time_Mode) 1978 and then not Is_OK_Static_Expression (Op) 1979 then 1980 return False; 1981 else 1982 return Compile_Time_Known_Value (Op); 1983 end if; 1984 end CRT_Safe_Compile_Time_Known_Value; 1985 1986 ----------------- 1987 -- Eval_Actual -- 1988 ----------------- 1989 1990 -- This is only called for actuals of functions that are not predefined 1991 -- operators (which have already been rewritten as operators at this 1992 -- stage), so the call can never be folded, and all that needs doing for 1993 -- the actual is to do the check for a non-static context. 1994 1995 procedure Eval_Actual (N : Node_Id) is 1996 begin 1997 Check_Non_Static_Context (N); 1998 end Eval_Actual; 1999 2000 -------------------- 2001 -- Eval_Allocator -- 2002 -------------------- 2003 2004 -- Allocators are never static, so all we have to do is to do the 2005 -- check for a non-static context if an expression is present. 2006 2007 procedure Eval_Allocator (N : Node_Id) is 2008 Expr : constant Node_Id := Expression (N); 2009 begin 2010 if Nkind (Expr) = N_Qualified_Expression then 2011 Check_Non_Static_Context (Expression (Expr)); 2012 end if; 2013 end Eval_Allocator; 2014 2015 ------------------------ 2016 -- Eval_Arithmetic_Op -- 2017 ------------------------ 2018 2019 -- Arithmetic operations are static functions, so the result is static 2020 -- if both operands are static (RM 4.9(7), 4.9(20)). 2021 2022 procedure Eval_Arithmetic_Op (N : Node_Id) is 2023 Left : constant Node_Id := Left_Opnd (N); 2024 Right : constant Node_Id := Right_Opnd (N); 2025 Ltype : constant Entity_Id := Etype (Left); 2026 Rtype : constant Entity_Id := Etype (Right); 2027 Otype : Entity_Id := Empty; 2028 Stat : Boolean; 2029 Fold : Boolean; 2030 2031 begin 2032 -- If not foldable we are done 2033 2034 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); 2035 2036 if not Fold then 2037 return; 2038 end if; 2039 2040 -- Otherwise attempt to fold 2041 2042 if Is_Universal_Numeric_Type (Etype (Left)) 2043 and then 2044 Is_Universal_Numeric_Type (Etype (Right)) 2045 then 2046 Otype := Find_Universal_Operator_Type (N); 2047 end if; 2048 2049 -- Fold for cases where both operands are of integer type 2050 2051 if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then 2052 declare 2053 Left_Int : constant Uint := Expr_Value (Left); 2054 Right_Int : constant Uint := Expr_Value (Right); 2055 Result : Uint; 2056 2057 begin 2058 case Nkind (N) is 2059 when N_Op_Add => 2060 Result := Left_Int + Right_Int; 2061 2062 when N_Op_Subtract => 2063 Result := Left_Int - Right_Int; 2064 2065 when N_Op_Multiply => 2066 if OK_Bits 2067 (N, UI_From_Int 2068 (Num_Bits (Left_Int) + Num_Bits (Right_Int))) 2069 then 2070 Result := Left_Int * Right_Int; 2071 else 2072 Result := Left_Int; 2073 end if; 2074 2075 when N_Op_Divide => 2076 2077 -- The exception Constraint_Error is raised by integer 2078 -- division, rem and mod if the right operand is zero. 2079 2080 if Right_Int = 0 then 2081 2082 -- When SPARK_Mode is On, force a warning instead of 2083 -- an error in that case, as this likely corresponds 2084 -- to deactivated code. 2085 2086 Apply_Compile_Time_Constraint_Error 2087 (N, "division by zero", CE_Divide_By_Zero, 2088 Warn => not Stat or SPARK_Mode = On); 2089 Set_Raises_Constraint_Error (N); 2090 return; 2091 2092 -- Otherwise we can do the division 2093 2094 else 2095 Result := Left_Int / Right_Int; 2096 end if; 2097 2098 when N_Op_Mod => 2099 2100 -- The exception Constraint_Error is raised by integer 2101 -- division, rem and mod if the right operand is zero. 2102 2103 if Right_Int = 0 then 2104 2105 -- When SPARK_Mode is On, force a warning instead of 2106 -- an error in that case, as this likely corresponds 2107 -- to deactivated code. 2108 2109 Apply_Compile_Time_Constraint_Error 2110 (N, "mod with zero divisor", CE_Divide_By_Zero, 2111 Warn => not Stat or SPARK_Mode = On); 2112 return; 2113 2114 else 2115 Result := Left_Int mod Right_Int; 2116 end if; 2117 2118 when N_Op_Rem => 2119 2120 -- The exception Constraint_Error is raised by integer 2121 -- division, rem and mod if the right operand is zero. 2122 2123 if Right_Int = 0 then 2124 2125 -- When SPARK_Mode is On, force a warning instead of 2126 -- an error in that case, as this likely corresponds 2127 -- to deactivated code. 2128 2129 Apply_Compile_Time_Constraint_Error 2130 (N, "rem with zero divisor", CE_Divide_By_Zero, 2131 Warn => not Stat or SPARK_Mode = On); 2132 return; 2133 2134 else 2135 Result := Left_Int rem Right_Int; 2136 end if; 2137 2138 when others => 2139 raise Program_Error; 2140 end case; 2141 2142 -- Adjust the result by the modulus if the type is a modular type 2143 2144 if Is_Modular_Integer_Type (Ltype) then 2145 Result := Result mod Modulus (Ltype); 2146 2147 -- For a signed integer type, check non-static overflow 2148 2149 elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then 2150 declare 2151 BT : constant Entity_Id := Base_Type (Ltype); 2152 Lo : constant Uint := Expr_Value (Type_Low_Bound (BT)); 2153 Hi : constant Uint := Expr_Value (Type_High_Bound (BT)); 2154 begin 2155 if Result < Lo or else Result > Hi then 2156 Apply_Compile_Time_Constraint_Error 2157 (N, "value not in range of }??", 2158 CE_Overflow_Check_Failed, 2159 Ent => BT); 2160 return; 2161 end if; 2162 end; 2163 end if; 2164 2165 -- If we get here we can fold the result 2166 2167 Fold_Uint (N, Result, Stat); 2168 end; 2169 2170 -- Cases where at least one operand is a real. We handle the cases of 2171 -- both reals, or mixed/real integer cases (the latter happen only for 2172 -- divide and multiply, and the result is always real). 2173 2174 elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then 2175 declare 2176 Left_Real : Ureal; 2177 Right_Real : Ureal; 2178 Result : Ureal; 2179 2180 begin 2181 if Is_Real_Type (Ltype) then 2182 Left_Real := Expr_Value_R (Left); 2183 else 2184 Left_Real := UR_From_Uint (Expr_Value (Left)); 2185 end if; 2186 2187 if Is_Real_Type (Rtype) then 2188 Right_Real := Expr_Value_R (Right); 2189 else 2190 Right_Real := UR_From_Uint (Expr_Value (Right)); 2191 end if; 2192 2193 if Nkind (N) = N_Op_Add then 2194 Result := Left_Real + Right_Real; 2195 2196 elsif Nkind (N) = N_Op_Subtract then 2197 Result := Left_Real - Right_Real; 2198 2199 elsif Nkind (N) = N_Op_Multiply then 2200 Result := Left_Real * Right_Real; 2201 2202 else pragma Assert (Nkind (N) = N_Op_Divide); 2203 if UR_Is_Zero (Right_Real) then 2204 Apply_Compile_Time_Constraint_Error 2205 (N, "division by zero", CE_Divide_By_Zero); 2206 return; 2207 end if; 2208 2209 Result := Left_Real / Right_Real; 2210 end if; 2211 2212 Fold_Ureal (N, Result, Stat); 2213 end; 2214 end if; 2215 2216 -- If the operator was resolved to a specific type, make sure that type 2217 -- is frozen even if the expression is folded into a literal (which has 2218 -- a universal type). 2219 2220 if Present (Otype) then 2221 Freeze_Before (N, Otype); 2222 end if; 2223 end Eval_Arithmetic_Op; 2224 2225 ---------------------------- 2226 -- Eval_Character_Literal -- 2227 ---------------------------- 2228 2229 -- Nothing to be done 2230 2231 procedure Eval_Character_Literal (N : Node_Id) is 2232 pragma Warnings (Off, N); 2233 begin 2234 null; 2235 end Eval_Character_Literal; 2236 2237 --------------- 2238 -- Eval_Call -- 2239 --------------- 2240 2241 -- Static function calls are either calls to predefined operators 2242 -- with static arguments, or calls to functions that rename a literal. 2243 -- Only the latter case is handled here, predefined operators are 2244 -- constant-folded elsewhere. 2245 2246 -- If the function is itself inherited the literal of the parent type must 2247 -- be explicitly converted to the return type of the function. 2248 2249 procedure Eval_Call (N : Node_Id) is 2250 Loc : constant Source_Ptr := Sloc (N); 2251 Typ : constant Entity_Id := Etype (N); 2252 Lit : Entity_Id; 2253 2254 begin 2255 if Nkind (N) = N_Function_Call 2256 and then No (Parameter_Associations (N)) 2257 and then Is_Entity_Name (Name (N)) 2258 and then Present (Alias (Entity (Name (N)))) 2259 and then Is_Enumeration_Type (Base_Type (Typ)) 2260 then 2261 Lit := Ultimate_Alias (Entity (Name (N))); 2262 2263 if Ekind (Lit) = E_Enumeration_Literal then 2264 if Base_Type (Etype (Lit)) /= Base_Type (Typ) then 2265 Rewrite 2266 (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc))); 2267 else 2268 Rewrite (N, New_Occurrence_Of (Lit, Loc)); 2269 end if; 2270 2271 Resolve (N, Typ); 2272 end if; 2273 2274 elsif Nkind (N) = N_Function_Call 2275 and then Is_Entity_Name (Name (N)) 2276 and then Is_Intrinsic_Subprogram (Entity (Name (N))) 2277 then 2278 Eval_Intrinsic_Call (N, Entity (Name (N))); 2279 2280 -- Ada 202x (AI12-0075): If checking for potentially static expressions 2281 -- is enabled and we have a call to a static function, substitute a 2282 -- static value for the call, to allow folding the expression. This 2283 -- supports checking the requirement of RM 6.8(5.3/5) in 2284 -- Analyze_Expression_Function. 2285 2286 elsif Checking_Potentially_Static_Expression 2287 and then Is_Static_Function_Call (N) 2288 then 2289 Fold_Dummy (N, Typ); 2290 end if; 2291 end Eval_Call; 2292 2293 -------------------------- 2294 -- Eval_Case_Expression -- 2295 -------------------------- 2296 2297 -- A conditional expression is static if all its conditions and dependent 2298 -- expressions are static. Note that we do not care if the dependent 2299 -- expressions raise CE, except for the one that will be selected. 2300 2301 procedure Eval_Case_Expression (N : Node_Id) is 2302 Alt : Node_Id; 2303 Choice : Node_Id; 2304 2305 begin 2306 Set_Is_Static_Expression (N, False); 2307 2308 if Error_Posted (Expression (N)) 2309 or else not Is_Static_Expression (Expression (N)) 2310 then 2311 Check_Non_Static_Context (Expression (N)); 2312 return; 2313 end if; 2314 2315 -- First loop, make sure all the alternatives are static expressions 2316 -- none of which raise Constraint_Error. We make the Constraint_Error 2317 -- check because part of the legality condition for a correct static 2318 -- case expression is that the cases are covered, like any other case 2319 -- expression. And we can't do that if any of the conditions raise an 2320 -- exception, so we don't even try to evaluate if that is the case. 2321 2322 Alt := First (Alternatives (N)); 2323 while Present (Alt) loop 2324 2325 -- The expression must be static, but we don't care at this stage 2326 -- if it raises Constraint_Error (the alternative might not match, 2327 -- in which case the expression is statically unevaluated anyway). 2328 2329 if not Is_Static_Expression (Expression (Alt)) then 2330 Check_Non_Static_Context (Expression (Alt)); 2331 return; 2332 end if; 2333 2334 -- The choices of a case always have to be static, and cannot raise 2335 -- an exception. If this condition is not met, then the expression 2336 -- is plain illegal, so just abandon evaluation attempts. No need 2337 -- to check non-static context when we have something illegal anyway. 2338 2339 if not Is_OK_Static_Choice_List (Discrete_Choices (Alt)) then 2340 return; 2341 end if; 2342 2343 Next (Alt); 2344 end loop; 2345 2346 -- OK, if the above loop gets through it means that all choices are OK 2347 -- static (don't raise exceptions), so the whole case is static, and we 2348 -- can find the matching alternative. 2349 2350 Set_Is_Static_Expression (N); 2351 2352 -- Now to deal with propagating a possible Constraint_Error 2353 2354 -- If the selecting expression raises CE, propagate and we are done 2355 2356 if Raises_Constraint_Error (Expression (N)) then 2357 Set_Raises_Constraint_Error (N); 2358 2359 -- Otherwise we need to check the alternatives to find the matching 2360 -- one. CE's in other than the matching one are not relevant. But we 2361 -- do need to check the matching one. Unlike the first loop, we do not 2362 -- have to go all the way through, when we find the matching one, quit. 2363 2364 else 2365 Alt := First (Alternatives (N)); 2366 Search : loop 2367 2368 -- We must find a match among the alternatives. If not, this must 2369 -- be due to other errors, so just ignore, leaving as non-static. 2370 2371 if No (Alt) then 2372 Set_Is_Static_Expression (N, False); 2373 return; 2374 end if; 2375 2376 -- Otherwise loop through choices of this alternative 2377 2378 Choice := First (Discrete_Choices (Alt)); 2379 while Present (Choice) loop 2380 2381 -- If we find a matching choice, then the Expression of this 2382 -- alternative replaces N (Raises_Constraint_Error flag is 2383 -- included, so we don't have to special case that). 2384 2385 if Choice_Matches (Expression (N), Choice) = Match then 2386 Rewrite (N, Relocate_Node (Expression (Alt))); 2387 return; 2388 end if; 2389 2390 Next (Choice); 2391 end loop; 2392 2393 Next (Alt); 2394 end loop Search; 2395 end if; 2396 end Eval_Case_Expression; 2397 2398 ------------------------ 2399 -- Eval_Concatenation -- 2400 ------------------------ 2401 2402 -- Concatenation is a static function, so the result is static if both 2403 -- operands are static (RM 4.9(7), 4.9(21)). 2404 2405 procedure Eval_Concatenation (N : Node_Id) is 2406 Left : constant Node_Id := Left_Opnd (N); 2407 Right : constant Node_Id := Right_Opnd (N); 2408 C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N))); 2409 Stat : Boolean; 2410 Fold : Boolean; 2411 2412 begin 2413 -- Concatenation is never static in Ada 83, so if Ada 83 check operand 2414 -- non-static context. 2415 2416 if Ada_Version = Ada_83 2417 and then Comes_From_Source (N) 2418 then 2419 Check_Non_Static_Context (Left); 2420 Check_Non_Static_Context (Right); 2421 return; 2422 end if; 2423 2424 -- If not foldable we are done. In principle concatenation that yields 2425 -- any string type is static (i.e. an array type of character types). 2426 -- However, character types can include enumeration literals, and 2427 -- concatenation in that case cannot be described by a literal, so we 2428 -- only consider the operation static if the result is an array of 2429 -- (a descendant of) a predefined character type. 2430 2431 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); 2432 2433 if not (Is_Standard_Character_Type (C_Typ) and then Fold) then 2434 Set_Is_Static_Expression (N, False); 2435 return; 2436 end if; 2437 2438 -- Compile time string concatenation 2439 2440 -- ??? Note that operands that are aggregates can be marked as static, 2441 -- so we should attempt at a later stage to fold concatenations with 2442 -- such aggregates. 2443 2444 declare 2445 Left_Str : constant Node_Id := Get_String_Val (Left); 2446 Left_Len : Nat; 2447 Right_Str : constant Node_Id := Get_String_Val (Right); 2448 Folded_Val : String_Id := No_String; 2449 2450 begin 2451 -- Establish new string literal, and store left operand. We make 2452 -- sure to use the special Start_String that takes an operand if 2453 -- the left operand is a string literal. Since this is optimized 2454 -- in the case where that is the most recently created string 2455 -- literal, we ensure efficient time/space behavior for the 2456 -- case of a concatenation of a series of string literals. 2457 2458 if Nkind (Left_Str) = N_String_Literal then 2459 Left_Len := String_Length (Strval (Left_Str)); 2460 2461 -- If the left operand is the empty string, and the right operand 2462 -- is a string literal (the case of "" & "..."), the result is the 2463 -- value of the right operand. This optimization is important when 2464 -- Is_Folded_In_Parser, to avoid copying an enormous right 2465 -- operand. 2466 2467 if Left_Len = 0 and then Nkind (Right_Str) = N_String_Literal then 2468 Folded_Val := Strval (Right_Str); 2469 else 2470 Start_String (Strval (Left_Str)); 2471 end if; 2472 2473 else 2474 Start_String; 2475 Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str))); 2476 Left_Len := 1; 2477 end if; 2478 2479 -- Now append the characters of the right operand, unless we 2480 -- optimized the "" & "..." case above. 2481 2482 if Nkind (Right_Str) = N_String_Literal then 2483 if Left_Len /= 0 then 2484 Store_String_Chars (Strval (Right_Str)); 2485 Folded_Val := End_String; 2486 end if; 2487 else 2488 Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str))); 2489 Folded_Val := End_String; 2490 end if; 2491 2492 Set_Is_Static_Expression (N, Stat); 2493 2494 -- If left operand is the empty string, the result is the 2495 -- right operand, including its bounds if anomalous. 2496 2497 if Left_Len = 0 2498 and then Is_Array_Type (Etype (Right)) 2499 and then Etype (Right) /= Any_String 2500 then 2501 Set_Etype (N, Etype (Right)); 2502 end if; 2503 2504 Fold_Str (N, Folded_Val, Static => Stat); 2505 end; 2506 end Eval_Concatenation; 2507 2508 ---------------------- 2509 -- Eval_Entity_Name -- 2510 ---------------------- 2511 2512 -- This procedure is used for identifiers and expanded names other than 2513 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are 2514 -- static if they denote a static constant (RM 4.9(6)) or if the name 2515 -- denotes an enumeration literal (RM 4.9(22)). 2516 2517 procedure Eval_Entity_Name (N : Node_Id) is 2518 Def_Id : constant Entity_Id := Entity (N); 2519 Val : Node_Id; 2520 2521 begin 2522 -- Enumeration literals are always considered to be constants 2523 -- and cannot raise Constraint_Error (RM 4.9(22)). 2524 2525 if Ekind (Def_Id) = E_Enumeration_Literal then 2526 Set_Is_Static_Expression (N); 2527 return; 2528 2529 -- A name is static if it denotes a static constant (RM 4.9(5)), and 2530 -- we also copy Raise_Constraint_Error. Notice that even if non-static, 2531 -- it does not violate 10.2.1(8) here, since this is not a variable. 2532 2533 elsif Ekind (Def_Id) = E_Constant then 2534 2535 -- Deferred constants must always be treated as nonstatic outside the 2536 -- scope of their full view. 2537 2538 if Present (Full_View (Def_Id)) 2539 and then not In_Open_Scopes (Scope (Def_Id)) 2540 then 2541 Val := Empty; 2542 else 2543 Val := Constant_Value (Def_Id); 2544 end if; 2545 2546 if Present (Val) then 2547 Set_Is_Static_Expression 2548 (N, Is_Static_Expression (Val) 2549 and then Is_Static_Subtype (Etype (Def_Id))); 2550 Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val)); 2551 2552 if not Is_Static_Expression (N) 2553 and then not Is_Generic_Type (Etype (N)) 2554 then 2555 Validate_Static_Object_Name (N); 2556 end if; 2557 2558 -- Mark constant condition in SCOs 2559 2560 if Generate_SCO 2561 and then Comes_From_Source (N) 2562 and then Is_Boolean_Type (Etype (Def_Id)) 2563 and then Compile_Time_Known_Value (N) 2564 then 2565 Set_SCO_Condition (N, Expr_Value_E (N) = Standard_True); 2566 end if; 2567 2568 return; 2569 end if; 2570 2571 -- Ada 202x (AI12-0075): If checking for potentially static expressions 2572 -- is enabled and we have a reference to a formal parameter of mode in, 2573 -- substitute a static value for the reference, to allow folding the 2574 -- expression. This supports checking the requirement of RM 6.8(5.3/5) 2575 -- in Analyze_Expression_Function. 2576 2577 elsif Ekind (Def_Id) = E_In_Parameter 2578 and then Checking_Potentially_Static_Expression 2579 and then Is_Static_Function (Scope (Def_Id)) 2580 then 2581 Fold_Dummy (N, Etype (Def_Id)); 2582 end if; 2583 2584 -- Fall through if the name is not static 2585 2586 Validate_Static_Object_Name (N); 2587 end Eval_Entity_Name; 2588 2589 ------------------------ 2590 -- Eval_If_Expression -- 2591 ------------------------ 2592 2593 -- We can fold to a static expression if the condition and both dependent 2594 -- expressions are static. Otherwise, the only required processing is to do 2595 -- the check for non-static context for the then and else expressions. 2596 2597 procedure Eval_If_Expression (N : Node_Id) is 2598 Condition : constant Node_Id := First (Expressions (N)); 2599 Then_Expr : constant Node_Id := Next (Condition); 2600 Else_Expr : constant Node_Id := Next (Then_Expr); 2601 Result : Node_Id; 2602 Non_Result : Node_Id; 2603 2604 Rstat : constant Boolean := 2605 Is_Static_Expression (Condition) 2606 and then 2607 Is_Static_Expression (Then_Expr) 2608 and then 2609 Is_Static_Expression (Else_Expr); 2610 -- True if result is static 2611 2612 begin 2613 -- If result not static, nothing to do, otherwise set static result 2614 2615 if not Rstat then 2616 return; 2617 else 2618 Set_Is_Static_Expression (N); 2619 end if; 2620 2621 -- If any operand is Any_Type, just propagate to result and do not try 2622 -- to fold, this prevents cascaded errors. 2623 2624 if Etype (Condition) = Any_Type or else 2625 Etype (Then_Expr) = Any_Type or else 2626 Etype (Else_Expr) = Any_Type 2627 then 2628 Set_Etype (N, Any_Type); 2629 Set_Is_Static_Expression (N, False); 2630 return; 2631 end if; 2632 2633 -- If condition raises Constraint_Error then we have already signaled 2634 -- an error, and we just propagate to the result and do not fold. 2635 2636 if Raises_Constraint_Error (Condition) then 2637 Set_Raises_Constraint_Error (N); 2638 return; 2639 end if; 2640 2641 -- Static case where we can fold. Note that we don't try to fold cases 2642 -- where the condition is known at compile time, but the result is 2643 -- non-static. This avoids possible cases of infinite recursion where 2644 -- the expander puts in a redundant test and we remove it. Instead we 2645 -- deal with these cases in the expander. 2646 2647 -- Select result operand 2648 2649 if Is_True (Expr_Value (Condition)) then 2650 Result := Then_Expr; 2651 Non_Result := Else_Expr; 2652 else 2653 Result := Else_Expr; 2654 Non_Result := Then_Expr; 2655 end if; 2656 2657 -- Note that it does not matter if the non-result operand raises a 2658 -- Constraint_Error, but if the result raises Constraint_Error then we 2659 -- replace the node with a raise Constraint_Error. This will properly 2660 -- propagate Raises_Constraint_Error since this flag is set in Result. 2661 2662 if Raises_Constraint_Error (Result) then 2663 Rewrite_In_Raise_CE (N, Result); 2664 Check_Non_Static_Context (Non_Result); 2665 2666 -- Otherwise the result operand replaces the original node 2667 2668 else 2669 Rewrite (N, Relocate_Node (Result)); 2670 Set_Is_Static_Expression (N); 2671 end if; 2672 end Eval_If_Expression; 2673 2674 ---------------------------- 2675 -- Eval_Indexed_Component -- 2676 ---------------------------- 2677 2678 -- Indexed components are never static, so we need to perform the check 2679 -- for non-static context on the index values. Then, we check if the 2680 -- value can be obtained at compile time, even though it is non-static. 2681 2682 procedure Eval_Indexed_Component (N : Node_Id) is 2683 Expr : Node_Id; 2684 2685 begin 2686 -- Check for non-static context on index values 2687 2688 Expr := First (Expressions (N)); 2689 while Present (Expr) loop 2690 Check_Non_Static_Context (Expr); 2691 Next (Expr); 2692 end loop; 2693 2694 -- If the indexed component appears in an object renaming declaration 2695 -- then we do not want to try to evaluate it, since in this case we 2696 -- need the identity of the array element. 2697 2698 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then 2699 return; 2700 2701 -- Similarly if the indexed component appears as the prefix of an 2702 -- attribute we don't want to evaluate it, because at least for 2703 -- some cases of attributes we need the identify (e.g. Access, Size). 2704 2705 elsif Nkind (Parent (N)) = N_Attribute_Reference then 2706 return; 2707 end if; 2708 2709 -- Note: there are other cases, such as the left side of an assignment, 2710 -- or an OUT parameter for a call, where the replacement results in the 2711 -- illegal use of a constant, But these cases are illegal in the first 2712 -- place, so the replacement, though silly, is harmless. 2713 2714 -- Now see if this is a constant array reference 2715 2716 if List_Length (Expressions (N)) = 1 2717 and then Is_Entity_Name (Prefix (N)) 2718 and then Ekind (Entity (Prefix (N))) = E_Constant 2719 and then Present (Constant_Value (Entity (Prefix (N)))) 2720 then 2721 declare 2722 Loc : constant Source_Ptr := Sloc (N); 2723 Arr : constant Node_Id := Constant_Value (Entity (Prefix (N))); 2724 Sub : constant Node_Id := First (Expressions (N)); 2725 2726 Atyp : Entity_Id; 2727 -- Type of array 2728 2729 Lin : Nat; 2730 -- Linear one's origin subscript value for array reference 2731 2732 Lbd : Node_Id; 2733 -- Lower bound of the first array index 2734 2735 Elm : Node_Id; 2736 -- Value from constant array 2737 2738 begin 2739 Atyp := Etype (Arr); 2740 2741 if Is_Access_Type (Atyp) then 2742 Atyp := Designated_Type (Atyp); 2743 end if; 2744 2745 -- If we have an array type (we should have but perhaps there are 2746 -- error cases where this is not the case), then see if we can do 2747 -- a constant evaluation of the array reference. 2748 2749 if Is_Array_Type (Atyp) and then Atyp /= Any_Composite then 2750 if Ekind (Atyp) = E_String_Literal_Subtype then 2751 Lbd := String_Literal_Low_Bound (Atyp); 2752 else 2753 Lbd := Type_Low_Bound (Etype (First_Index (Atyp))); 2754 end if; 2755 2756 if Compile_Time_Known_Value (Sub) 2757 and then Nkind (Arr) = N_Aggregate 2758 and then Compile_Time_Known_Value (Lbd) 2759 and then Is_Discrete_Type (Component_Type (Atyp)) 2760 then 2761 Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1; 2762 2763 if List_Length (Expressions (Arr)) >= Lin then 2764 Elm := Pick (Expressions (Arr), Lin); 2765 2766 -- If the resulting expression is compile-time-known, 2767 -- then we can rewrite the indexed component with this 2768 -- value, being sure to mark the result as non-static. 2769 -- We also reset the Sloc, in case this generates an 2770 -- error later on (e.g. 136'Access). 2771 2772 if Compile_Time_Known_Value (Elm) then 2773 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm)); 2774 Set_Is_Static_Expression (N, False); 2775 Set_Sloc (N, Loc); 2776 end if; 2777 end if; 2778 2779 -- We can also constant-fold if the prefix is a string literal. 2780 -- This will be useful in an instantiation or an inlining. 2781 2782 elsif Compile_Time_Known_Value (Sub) 2783 and then Nkind (Arr) = N_String_Literal 2784 and then Compile_Time_Known_Value (Lbd) 2785 and then Expr_Value (Lbd) = 1 2786 and then Expr_Value (Sub) <= 2787 String_Literal_Length (Etype (Arr)) 2788 then 2789 declare 2790 C : constant Char_Code := 2791 Get_String_Char (Strval (Arr), 2792 UI_To_Int (Expr_Value (Sub))); 2793 begin 2794 Set_Character_Literal_Name (C); 2795 2796 Elm := 2797 Make_Character_Literal (Loc, 2798 Chars => Name_Find, 2799 Char_Literal_Value => UI_From_CC (C)); 2800 Set_Etype (Elm, Component_Type (Atyp)); 2801 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm)); 2802 Set_Is_Static_Expression (N, False); 2803 end; 2804 end if; 2805 end if; 2806 end; 2807 end if; 2808 end Eval_Indexed_Component; 2809 2810 -------------------------- 2811 -- Eval_Integer_Literal -- 2812 -------------------------- 2813 2814 -- Numeric literals are static (RM 4.9(1)), and have already been marked 2815 -- as static by the analyzer. The reason we did it that early is to allow 2816 -- the possibility of turning off the Is_Static_Expression flag after 2817 -- analysis, but before resolution, when integer literals are generated in 2818 -- the expander that do not correspond to static expressions. 2819 2820 procedure Eval_Integer_Literal (N : Node_Id) is 2821 function In_Any_Integer_Context (Context : Node_Id) return Boolean; 2822 -- If the literal is resolved with a specific type in a context where 2823 -- the expected type is Any_Integer, there are no range checks on the 2824 -- literal. By the time the literal is evaluated, it carries the type 2825 -- imposed by the enclosing expression, and we must recover the context 2826 -- to determine that Any_Integer is meant. 2827 2828 ---------------------------- 2829 -- In_Any_Integer_Context -- 2830 ---------------------------- 2831 2832 function In_Any_Integer_Context (Context : Node_Id) return Boolean is 2833 begin 2834 -- Any_Integer also appears in digits specifications for real types, 2835 -- but those have bounds smaller that those of any integer base type, 2836 -- so we can safely ignore these cases. 2837 2838 return 2839 Nkind (Context) in N_Attribute_Definition_Clause 2840 | N_Attribute_Reference 2841 | N_Modular_Type_Definition 2842 | N_Number_Declaration 2843 | N_Signed_Integer_Type_Definition; 2844 end In_Any_Integer_Context; 2845 2846 -- Local variables 2847 2848 Par : constant Node_Id := Parent (N); 2849 Typ : constant Entity_Id := Etype (N); 2850 2851 -- Start of processing for Eval_Integer_Literal 2852 2853 begin 2854 -- If the literal appears in a non-expression context, then it is 2855 -- certainly appearing in a non-static context, so check it. This is 2856 -- actually a redundant check, since Check_Non_Static_Context would 2857 -- check it, but it seems worthwhile to optimize out the call. 2858 2859 -- Additionally, when the literal appears within an if or case 2860 -- expression it must be checked as well. However, due to the literal 2861 -- appearing within a conditional statement, expansion greatly changes 2862 -- the nature of its context and performing some of the checks within 2863 -- Check_Non_Static_Context on an expanded literal may lead to spurious 2864 -- and misleading warnings. 2865 2866 if (Nkind (Par) in N_Case_Expression_Alternative | N_If_Expression 2867 or else Nkind (Par) not in N_Subexpr) 2868 and then (Nkind (Par) not in N_Case_Expression_Alternative 2869 | N_If_Expression 2870 or else Comes_From_Source (N)) 2871 and then not In_Any_Integer_Context (Par) 2872 then 2873 Check_Non_Static_Context (N); 2874 end if; 2875 2876 -- Modular integer literals must be in their base range 2877 2878 if Is_Modular_Integer_Type (Typ) 2879 and then Is_Out_Of_Range (N, Base_Type (Typ), Assume_Valid => True) 2880 then 2881 Out_Of_Range (N); 2882 end if; 2883 end Eval_Integer_Literal; 2884 2885 ------------------------- 2886 -- Eval_Intrinsic_Call -- 2887 ------------------------- 2888 2889 procedure Eval_Intrinsic_Call (N : Node_Id; E : Entity_Id) is 2890 2891 procedure Eval_Shift (N : Node_Id; E : Entity_Id; Op : Node_Kind); 2892 -- Evaluate an intrinsic shift call N on the given subprogram E. 2893 -- Op is the kind for the shift node. 2894 2895 ---------------- 2896 -- Eval_Shift -- 2897 ---------------- 2898 2899 procedure Eval_Shift (N : Node_Id; E : Entity_Id; Op : Node_Kind) is 2900 Left : constant Node_Id := First_Actual (N); 2901 Right : constant Node_Id := Next_Actual (Left); 2902 Static : constant Boolean := Is_Static_Function (E); 2903 2904 begin 2905 if Static then 2906 if Checking_Potentially_Static_Expression then 2907 Fold_Dummy (N, Etype (N)); 2908 return; 2909 end if; 2910 end if; 2911 2912 Fold_Shift 2913 (N, Left, Right, Op, Static => Static, Check_Elab => not Static); 2914 end Eval_Shift; 2915 2916 Nam : Name_Id; 2917 2918 begin 2919 -- Nothing to do if the intrinsic is handled by the back end. 2920 2921 if Present (Interface_Name (E)) then 2922 return; 2923 end if; 2924 2925 -- Intrinsic calls as part of a static function is a language extension. 2926 2927 if Checking_Potentially_Static_Expression 2928 and then not Extensions_Allowed 2929 then 2930 return; 2931 end if; 2932 2933 -- If we have a renaming, expand the call to the original operation, 2934 -- which must itself be intrinsic, since renaming requires matching 2935 -- conventions and this has already been checked. 2936 2937 if Present (Alias (E)) then 2938 Eval_Intrinsic_Call (N, Alias (E)); 2939 return; 2940 end if; 2941 2942 -- If the intrinsic subprogram is generic, gets its original name 2943 2944 if Present (Parent (E)) 2945 and then Present (Generic_Parent (Parent (E))) 2946 then 2947 Nam := Chars (Generic_Parent (Parent (E))); 2948 else 2949 Nam := Chars (E); 2950 end if; 2951 2952 case Nam is 2953 when Name_Shift_Left => 2954 Eval_Shift (N, E, N_Op_Shift_Left); 2955 when Name_Shift_Right => 2956 Eval_Shift (N, E, N_Op_Shift_Right); 2957 when Name_Shift_Right_Arithmetic => 2958 Eval_Shift (N, E, N_Op_Shift_Right_Arithmetic); 2959 when others => 2960 null; 2961 end case; 2962 end Eval_Intrinsic_Call; 2963 2964 --------------------- 2965 -- Eval_Logical_Op -- 2966 --------------------- 2967 2968 -- Logical operations are static functions, so the result is potentially 2969 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)). 2970 2971 procedure Eval_Logical_Op (N : Node_Id) is 2972 Left : constant Node_Id := Left_Opnd (N); 2973 Right : constant Node_Id := Right_Opnd (N); 2974 Stat : Boolean; 2975 Fold : Boolean; 2976 2977 begin 2978 -- If not foldable we are done 2979 2980 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); 2981 2982 if not Fold then 2983 return; 2984 end if; 2985 2986 -- Compile time evaluation of logical operation 2987 2988 declare 2989 Left_Int : constant Uint := Expr_Value (Left); 2990 Right_Int : constant Uint := Expr_Value (Right); 2991 2992 begin 2993 if Is_Modular_Integer_Type (Etype (N)) then 2994 declare 2995 Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); 2996 Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); 2997 2998 begin 2999 To_Bits (Left_Int, Left_Bits); 3000 To_Bits (Right_Int, Right_Bits); 3001 3002 -- Note: should really be able to use array ops instead of 3003 -- these loops, but they break the build with a cryptic error 3004 -- during the bind of gnat1 likely due to a wrong computation 3005 -- of a date or checksum. 3006 3007 if Nkind (N) = N_Op_And then 3008 for J in Left_Bits'Range loop 3009 Left_Bits (J) := Left_Bits (J) and Right_Bits (J); 3010 end loop; 3011 3012 elsif Nkind (N) = N_Op_Or then 3013 for J in Left_Bits'Range loop 3014 Left_Bits (J) := Left_Bits (J) or Right_Bits (J); 3015 end loop; 3016 3017 else 3018 pragma Assert (Nkind (N) = N_Op_Xor); 3019 3020 for J in Left_Bits'Range loop 3021 Left_Bits (J) := Left_Bits (J) xor Right_Bits (J); 3022 end loop; 3023 end if; 3024 3025 Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat); 3026 end; 3027 3028 else 3029 pragma Assert (Is_Boolean_Type (Etype (N))); 3030 3031 if Nkind (N) = N_Op_And then 3032 Fold_Uint (N, 3033 Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat); 3034 3035 elsif Nkind (N) = N_Op_Or then 3036 Fold_Uint (N, 3037 Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat); 3038 3039 else 3040 pragma Assert (Nkind (N) = N_Op_Xor); 3041 Fold_Uint (N, 3042 Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat); 3043 end if; 3044 end if; 3045 end; 3046 end Eval_Logical_Op; 3047 3048 ------------------------ 3049 -- Eval_Membership_Op -- 3050 ------------------------ 3051 3052 -- A membership test is potentially static if the expression is static, and 3053 -- the range is a potentially static range, or is a subtype mark denoting a 3054 -- static subtype (RM 4.9(12)). 3055 3056 procedure Eval_Membership_Op (N : Node_Id) is 3057 Alts : constant List_Id := Alternatives (N); 3058 Choice : constant Node_Id := Right_Opnd (N); 3059 Expr : constant Node_Id := Left_Opnd (N); 3060 Result : Match_Result; 3061 3062 begin 3063 -- Ignore if error in either operand, except to make sure that Any_Type 3064 -- is properly propagated to avoid junk cascaded errors. 3065 3066 if Etype (Expr) = Any_Type 3067 or else (Present (Choice) and then Etype (Choice) = Any_Type) 3068 then 3069 Set_Etype (N, Any_Type); 3070 return; 3071 end if; 3072 3073 -- If left operand non-static, then nothing to do 3074 3075 if not Is_Static_Expression (Expr) then 3076 return; 3077 end if; 3078 3079 -- If choice is non-static, left operand is in non-static context 3080 3081 if (Present (Choice) and then not Is_Static_Choice (Choice)) 3082 or else (Present (Alts) and then not Is_Static_Choice_List (Alts)) 3083 then 3084 Check_Non_Static_Context (Expr); 3085 return; 3086 end if; 3087 3088 -- Otherwise we definitely have a static expression 3089 3090 Set_Is_Static_Expression (N); 3091 3092 -- If left operand raises Constraint_Error, propagate and we are done 3093 3094 if Raises_Constraint_Error (Expr) then 3095 Set_Raises_Constraint_Error (N, True); 3096 3097 -- See if we match 3098 3099 else 3100 if Present (Choice) then 3101 Result := Choice_Matches (Expr, Choice); 3102 else 3103 Result := Choices_Match (Expr, Alts); 3104 end if; 3105 3106 -- If result is Non_Static, it means that we raise Constraint_Error, 3107 -- since we already tested that the operands were themselves static. 3108 3109 if Result = Non_Static then 3110 Set_Raises_Constraint_Error (N); 3111 3112 -- Otherwise we have our result (flipped if NOT IN case) 3113 3114 else 3115 Fold_Uint 3116 (N, Test ((Result = Match) xor (Nkind (N) = N_Not_In)), True); 3117 Warn_On_Known_Condition (N); 3118 end if; 3119 end if; 3120 end Eval_Membership_Op; 3121 3122 ------------------------ 3123 -- Eval_Named_Integer -- 3124 ------------------------ 3125 3126 procedure Eval_Named_Integer (N : Node_Id) is 3127 begin 3128 Fold_Uint (N, 3129 Expr_Value (Expression (Declaration_Node (Entity (N)))), True); 3130 end Eval_Named_Integer; 3131 3132 --------------------- 3133 -- Eval_Named_Real -- 3134 --------------------- 3135 3136 procedure Eval_Named_Real (N : Node_Id) is 3137 begin 3138 Fold_Ureal (N, 3139 Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True); 3140 end Eval_Named_Real; 3141 3142 ------------------- 3143 -- Eval_Op_Expon -- 3144 ------------------- 3145 3146 -- Exponentiation is a static functions, so the result is potentially 3147 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)). 3148 3149 procedure Eval_Op_Expon (N : Node_Id) is 3150 Left : constant Node_Id := Left_Opnd (N); 3151 Right : constant Node_Id := Right_Opnd (N); 3152 Stat : Boolean; 3153 Fold : Boolean; 3154 3155 begin 3156 -- If not foldable we are done 3157 3158 Test_Expression_Is_Foldable 3159 (N, Left, Right, Stat, Fold, CRT_Safe => True); 3160 3161 -- Return if not foldable 3162 3163 if not Fold then 3164 return; 3165 end if; 3166 3167 if Configurable_Run_Time_Mode and not Stat then 3168 return; 3169 end if; 3170 3171 -- Fold exponentiation operation 3172 3173 declare 3174 Right_Int : constant Uint := Expr_Value (Right); 3175 3176 begin 3177 -- Integer case 3178 3179 if Is_Integer_Type (Etype (Left)) then 3180 declare 3181 Left_Int : constant Uint := Expr_Value (Left); 3182 Result : Uint; 3183 3184 begin 3185 -- Exponentiation of an integer raises Constraint_Error for a 3186 -- negative exponent (RM 4.5.6). 3187 3188 if Right_Int < 0 then 3189 Apply_Compile_Time_Constraint_Error 3190 (N, "integer exponent negative", CE_Range_Check_Failed, 3191 Warn => not Stat); 3192 return; 3193 3194 else 3195 if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then 3196 Result := Left_Int ** Right_Int; 3197 else 3198 Result := Left_Int; 3199 end if; 3200 3201 if Is_Modular_Integer_Type (Etype (N)) then 3202 Result := Result mod Modulus (Etype (N)); 3203 end if; 3204 3205 Fold_Uint (N, Result, Stat); 3206 end if; 3207 end; 3208 3209 -- Real case 3210 3211 else 3212 declare 3213 Left_Real : constant Ureal := Expr_Value_R (Left); 3214 3215 begin 3216 -- Cannot have a zero base with a negative exponent 3217 3218 if UR_Is_Zero (Left_Real) then 3219 3220 if Right_Int < 0 then 3221 Apply_Compile_Time_Constraint_Error 3222 (N, "zero ** negative integer", CE_Range_Check_Failed, 3223 Warn => not Stat); 3224 return; 3225 else 3226 Fold_Ureal (N, Ureal_0, Stat); 3227 end if; 3228 3229 else 3230 Fold_Ureal (N, Left_Real ** Right_Int, Stat); 3231 end if; 3232 end; 3233 end if; 3234 end; 3235 end Eval_Op_Expon; 3236 3237 ----------------- 3238 -- Eval_Op_Not -- 3239 ----------------- 3240 3241 -- The not operation is a static function, so the result is potentially 3242 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)). 3243 3244 procedure Eval_Op_Not (N : Node_Id) is 3245 Right : constant Node_Id := Right_Opnd (N); 3246 Stat : Boolean; 3247 Fold : Boolean; 3248 3249 begin 3250 -- If not foldable we are done 3251 3252 Test_Expression_Is_Foldable (N, Right, Stat, Fold); 3253 3254 if not Fold then 3255 return; 3256 end if; 3257 3258 -- Fold not operation 3259 3260 declare 3261 Rint : constant Uint := Expr_Value (Right); 3262 Typ : constant Entity_Id := Etype (N); 3263 3264 begin 3265 -- Negation is equivalent to subtracting from the modulus minus one. 3266 -- For a binary modulus this is equivalent to the ones-complement of 3267 -- the original value. For a nonbinary modulus this is an arbitrary 3268 -- but consistent definition. 3269 3270 if Is_Modular_Integer_Type (Typ) then 3271 Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat); 3272 else pragma Assert (Is_Boolean_Type (Typ)); 3273 Fold_Uint (N, Test (not Is_True (Rint)), Stat); 3274 end if; 3275 3276 Set_Is_Static_Expression (N, Stat); 3277 end; 3278 end Eval_Op_Not; 3279 3280 ------------------------------- 3281 -- Eval_Qualified_Expression -- 3282 ------------------------------- 3283 3284 -- A qualified expression is potentially static if its subtype mark denotes 3285 -- a static subtype and its expression is potentially static (RM 4.9 (10)). 3286 3287 procedure Eval_Qualified_Expression (N : Node_Id) is 3288 Operand : constant Node_Id := Expression (N); 3289 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N)); 3290 3291 Stat : Boolean; 3292 Fold : Boolean; 3293 Hex : Boolean; 3294 3295 begin 3296 -- Can only fold if target is string or scalar and subtype is static. 3297 -- Also, do not fold if our parent is an allocator (this is because the 3298 -- qualified expression is really part of the syntactic structure of an 3299 -- allocator, and we do not want to end up with something that 3300 -- corresponds to "new 1" where the 1 is the result of folding a 3301 -- qualified expression). 3302 3303 if not Is_Static_Subtype (Target_Type) 3304 or else Nkind (Parent (N)) = N_Allocator 3305 then 3306 Check_Non_Static_Context (Operand); 3307 3308 -- If operand is known to raise Constraint_Error, set the flag on the 3309 -- expression so it does not get optimized away. 3310 3311 if Nkind (Operand) = N_Raise_Constraint_Error then 3312 Set_Raises_Constraint_Error (N); 3313 end if; 3314 3315 return; 3316 3317 -- Also return if a semantic error has been posted on the node, as we 3318 -- don't want to fold in that case (for GNATprove, the node might lead 3319 -- to Constraint_Error but won't have been replaced with a raise node 3320 -- or marked as raising CE). 3321 3322 elsif Error_Posted (N) then 3323 return; 3324 end if; 3325 3326 -- If not foldable we are done 3327 3328 Test_Expression_Is_Foldable (N, Operand, Stat, Fold); 3329 3330 if not Fold then 3331 return; 3332 3333 -- Don't try fold if target type has Constraint_Error bounds 3334 3335 elsif not Is_OK_Static_Subtype (Target_Type) then 3336 Set_Raises_Constraint_Error (N); 3337 return; 3338 end if; 3339 3340 -- Fold the result of qualification 3341 3342 if Is_Discrete_Type (Target_Type) then 3343 3344 -- Save Print_In_Hex indication 3345 3346 Hex := Nkind (Operand) = N_Integer_Literal 3347 and then Print_In_Hex (Operand); 3348 3349 Fold_Uint (N, Expr_Value (Operand), Stat); 3350 3351 -- Preserve Print_In_Hex indication 3352 3353 if Hex and then Nkind (N) = N_Integer_Literal then 3354 Set_Print_In_Hex (N); 3355 end if; 3356 3357 elsif Is_Real_Type (Target_Type) then 3358 Fold_Ureal (N, Expr_Value_R (Operand), Stat); 3359 3360 else 3361 Fold_Str (N, Strval (Get_String_Val (Operand)), Stat); 3362 3363 if not Stat then 3364 Set_Is_Static_Expression (N, False); 3365 else 3366 Check_String_Literal_Length (N, Target_Type); 3367 end if; 3368 3369 return; 3370 end if; 3371 3372 -- The expression may be foldable but not static 3373 3374 Set_Is_Static_Expression (N, Stat); 3375 3376 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then 3377 Out_Of_Range (N); 3378 end if; 3379 end Eval_Qualified_Expression; 3380 3381 ----------------------- 3382 -- Eval_Real_Literal -- 3383 ----------------------- 3384 3385 -- Numeric literals are static (RM 4.9(1)), and have already been marked 3386 -- as static by the analyzer. The reason we did it that early is to allow 3387 -- the possibility of turning off the Is_Static_Expression flag after 3388 -- analysis, but before resolution, when integer literals are generated 3389 -- in the expander that do not correspond to static expressions. 3390 3391 procedure Eval_Real_Literal (N : Node_Id) is 3392 PK : constant Node_Kind := Nkind (Parent (N)); 3393 3394 begin 3395 -- If the literal appears in a non-expression context and not as part of 3396 -- a number declaration, then it is appearing in a non-static context, 3397 -- so check it. 3398 3399 if PK not in N_Subexpr and then PK /= N_Number_Declaration then 3400 Check_Non_Static_Context (N); 3401 end if; 3402 end Eval_Real_Literal; 3403 3404 ------------------------ 3405 -- Eval_Relational_Op -- 3406 ------------------------ 3407 3408 -- Relational operations are static functions, so the result is static if 3409 -- both operands are static (RM 4.9(7), 4.9(20)), except that up to Ada 3410 -- 2012, for strings the result is never static, even if the operands are. 3411 -- The string case was relaxed in Ada 2020, see AI12-0201. 3412 3413 -- However, for internally generated nodes, we allow string equality and 3414 -- inequality to be static. This is because we rewrite A in "ABC" as an 3415 -- equality test A = "ABC", and the former is definitely static. 3416 3417 procedure Eval_Relational_Op (N : Node_Id) is 3418 Left : constant Node_Id := Left_Opnd (N); 3419 Right : constant Node_Id := Right_Opnd (N); 3420 3421 procedure Decompose_Expr 3422 (Expr : Node_Id; 3423 Ent : out Entity_Id; 3424 Kind : out Character; 3425 Cons : out Uint; 3426 Orig : Boolean := True); 3427 -- Given expression Expr, see if it is of the form X [+/- K]. If so, Ent 3428 -- is set to the entity in X, Kind is 'F','L','E' for 'First or 'Last or 3429 -- simple entity, and Cons is the value of K. If the expression is not 3430 -- of the required form, Ent is set to Empty. 3431 -- 3432 -- Orig indicates whether Expr is the original expression to consider, 3433 -- or if we are handling a subexpression (e.g. recursive call to 3434 -- Decompose_Expr). 3435 3436 procedure Fold_General_Op (Is_Static : Boolean); 3437 -- Attempt to fold arbitrary relational operator N. Flag Is_Static must 3438 -- be set when the operator denotes a static expression. 3439 3440 procedure Fold_Static_Real_Op; 3441 -- Attempt to fold static real type relational operator N 3442 3443 function Static_Length (Expr : Node_Id) return Uint; 3444 -- If Expr is an expression for a constrained array whose length is 3445 -- known at compile time, return the non-negative length, otherwise 3446 -- return -1. 3447 3448 -------------------- 3449 -- Decompose_Expr -- 3450 -------------------- 3451 3452 procedure Decompose_Expr 3453 (Expr : Node_Id; 3454 Ent : out Entity_Id; 3455 Kind : out Character; 3456 Cons : out Uint; 3457 Orig : Boolean := True) 3458 is 3459 Exp : Node_Id; 3460 3461 begin 3462 -- Assume that the expression does not meet the expected form 3463 3464 Cons := No_Uint; 3465 Ent := Empty; 3466 Kind := '?'; 3467 3468 if Nkind (Expr) = N_Op_Add 3469 and then Compile_Time_Known_Value (Right_Opnd (Expr)) 3470 then 3471 Exp := Left_Opnd (Expr); 3472 Cons := Expr_Value (Right_Opnd (Expr)); 3473 3474 elsif Nkind (Expr) = N_Op_Subtract 3475 and then Compile_Time_Known_Value (Right_Opnd (Expr)) 3476 then 3477 Exp := Left_Opnd (Expr); 3478 Cons := -Expr_Value (Right_Opnd (Expr)); 3479 3480 -- If the bound is a constant created to remove side effects, recover 3481 -- the original expression to see if it has one of the recognizable 3482 -- forms. 3483 3484 elsif Nkind (Expr) = N_Identifier 3485 and then not Comes_From_Source (Entity (Expr)) 3486 and then Ekind (Entity (Expr)) = E_Constant 3487 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration 3488 then 3489 Exp := Expression (Parent (Entity (Expr))); 3490 Decompose_Expr (Exp, Ent, Kind, Cons, Orig => False); 3491 3492 -- If original expression includes an entity, create a reference 3493 -- to it for use below. 3494 3495 if Present (Ent) then 3496 Exp := New_Occurrence_Of (Ent, Sloc (Ent)); 3497 else 3498 return; 3499 end if; 3500 3501 else 3502 -- Only consider the case of X + 0 for a full expression, and 3503 -- not when recursing, otherwise we may end up with evaluating 3504 -- expressions not known at compile time to 0. 3505 3506 if Orig then 3507 Exp := Expr; 3508 Cons := Uint_0; 3509 else 3510 return; 3511 end if; 3512 end if; 3513 3514 -- At this stage Exp is set to the potential X 3515 3516 if Nkind (Exp) = N_Attribute_Reference then 3517 if Attribute_Name (Exp) = Name_First then 3518 Kind := 'F'; 3519 elsif Attribute_Name (Exp) = Name_Last then 3520 Kind := 'L'; 3521 else 3522 return; 3523 end if; 3524 3525 Exp := Prefix (Exp); 3526 3527 else 3528 Kind := 'E'; 3529 end if; 3530 3531 if Is_Entity_Name (Exp) and then Present (Entity (Exp)) then 3532 Ent := Entity (Exp); 3533 end if; 3534 end Decompose_Expr; 3535 3536 --------------------- 3537 -- Fold_General_Op -- 3538 --------------------- 3539 3540 procedure Fold_General_Op (Is_Static : Boolean) is 3541 CR : constant Compare_Result := 3542 Compile_Time_Compare (Left, Right, Assume_Valid => False); 3543 3544 Result : Boolean; 3545 3546 begin 3547 if CR = Unknown then 3548 return; 3549 end if; 3550 3551 case Nkind (N) is 3552 when N_Op_Eq => 3553 if CR = EQ then 3554 Result := True; 3555 elsif CR = NE or else CR = GT or else CR = LT then 3556 Result := False; 3557 else 3558 return; 3559 end if; 3560 3561 when N_Op_Ge => 3562 if CR = GT or else CR = EQ or else CR = GE then 3563 Result := True; 3564 elsif CR = LT then 3565 Result := False; 3566 else 3567 return; 3568 end if; 3569 3570 when N_Op_Gt => 3571 if CR = GT then 3572 Result := True; 3573 elsif CR = EQ or else CR = LT or else CR = LE then 3574 Result := False; 3575 else 3576 return; 3577 end if; 3578 3579 when N_Op_Le => 3580 if CR = LT or else CR = EQ or else CR = LE then 3581 Result := True; 3582 elsif CR = GT then 3583 Result := False; 3584 else 3585 return; 3586 end if; 3587 3588 when N_Op_Lt => 3589 if CR = LT then 3590 Result := True; 3591 elsif CR = EQ or else CR = GT or else CR = GE then 3592 Result := False; 3593 else 3594 return; 3595 end if; 3596 3597 when N_Op_Ne => 3598 if CR = NE or else CR = GT or else CR = LT then 3599 Result := True; 3600 elsif CR = EQ then 3601 Result := False; 3602 else 3603 return; 3604 end if; 3605 3606 when others => 3607 raise Program_Error; 3608 end case; 3609 3610 -- Determine the potential outcome of the relation assuming the 3611 -- operands are valid and emit a warning when the relation yields 3612 -- True or False only in the presence of invalid values. 3613 3614 Warn_On_Constant_Valid_Condition (N); 3615 3616 Fold_Uint (N, Test (Result), Is_Static); 3617 end Fold_General_Op; 3618 3619 ------------------------- 3620 -- Fold_Static_Real_Op -- 3621 ------------------------- 3622 3623 procedure Fold_Static_Real_Op is 3624 Left_Real : constant Ureal := Expr_Value_R (Left); 3625 Right_Real : constant Ureal := Expr_Value_R (Right); 3626 Result : Boolean; 3627 3628 begin 3629 case Nkind (N) is 3630 when N_Op_Eq => Result := (Left_Real = Right_Real); 3631 when N_Op_Ge => Result := (Left_Real >= Right_Real); 3632 when N_Op_Gt => Result := (Left_Real > Right_Real); 3633 when N_Op_Le => Result := (Left_Real <= Right_Real); 3634 when N_Op_Lt => Result := (Left_Real < Right_Real); 3635 when N_Op_Ne => Result := (Left_Real /= Right_Real); 3636 when others => raise Program_Error; 3637 end case; 3638 3639 Fold_Uint (N, Test (Result), True); 3640 end Fold_Static_Real_Op; 3641 3642 ------------------- 3643 -- Static_Length -- 3644 ------------------- 3645 3646 function Static_Length (Expr : Node_Id) return Uint is 3647 Cons1 : Uint; 3648 Cons2 : Uint; 3649 Ent1 : Entity_Id; 3650 Ent2 : Entity_Id; 3651 Kind1 : Character; 3652 Kind2 : Character; 3653 Typ : Entity_Id; 3654 3655 begin 3656 -- First easy case string literal 3657 3658 if Nkind (Expr) = N_String_Literal then 3659 return UI_From_Int (String_Length (Strval (Expr))); 3660 3661 -- With frontend inlining as performed in GNATprove mode, a variable 3662 -- may be inserted that has a string literal subtype. Deal with this 3663 -- specially as for the previous case. 3664 3665 elsif Ekind (Etype (Expr)) = E_String_Literal_Subtype then 3666 return String_Literal_Length (Etype (Expr)); 3667 3668 -- Second easy case, not constrained subtype, so no length 3669 3670 elsif not Is_Constrained (Etype (Expr)) then 3671 return Uint_Minus_1; 3672 end if; 3673 3674 -- General case 3675 3676 Typ := Etype (First_Index (Etype (Expr))); 3677 3678 -- The simple case, both bounds are known at compile time 3679 3680 if Is_Discrete_Type (Typ) 3681 and then Compile_Time_Known_Value (Type_Low_Bound (Typ)) 3682 and then Compile_Time_Known_Value (Type_High_Bound (Typ)) 3683 then 3684 return 3685 UI_Max (Uint_0, Expr_Value (Type_High_Bound (Typ)) - 3686 Expr_Value (Type_Low_Bound (Typ)) + 1); 3687 end if; 3688 3689 -- A more complex case, where the bounds are of the form X [+/- K1] 3690 -- .. X [+/- K2]), where X is an expression that is either A'First or 3691 -- A'Last (with A an entity name), or X is an entity name, and the 3692 -- two X's are the same and K1 and K2 are known at compile time, in 3693 -- this case, the length can also be computed at compile time, even 3694 -- though the bounds are not known. A common case of this is e.g. 3695 -- (X'First .. X'First+5). 3696 3697 Decompose_Expr 3698 (Original_Node (Type_Low_Bound (Typ)), Ent1, Kind1, Cons1); 3699 Decompose_Expr 3700 (Original_Node (Type_High_Bound (Typ)), Ent2, Kind2, Cons2); 3701 3702 if Present (Ent1) and then Ent1 = Ent2 and then Kind1 = Kind2 then 3703 return Cons2 - Cons1 + 1; 3704 else 3705 return Uint_Minus_1; 3706 end if; 3707 end Static_Length; 3708 3709 -- Local variables 3710 3711 Left_Typ : constant Entity_Id := Etype (Left); 3712 Right_Typ : constant Entity_Id := Etype (Right); 3713 Fold : Boolean; 3714 Left_Len : Uint; 3715 Op_Typ : Entity_Id := Empty; 3716 Right_Len : Uint; 3717 3718 Is_Static_Expression : Boolean; 3719 3720 -- Start of processing for Eval_Relational_Op 3721 3722 begin 3723 -- One special case to deal with first. If we can tell that the result 3724 -- will be false because the lengths of one or more index subtypes are 3725 -- compile-time known and different, then we can replace the entire 3726 -- result by False. We only do this for one-dimensional arrays, because 3727 -- the case of multidimensional arrays is rare and too much trouble. If 3728 -- one of the operands is an illegal aggregate, its type might still be 3729 -- an arbitrary composite type, so nothing to do. 3730 3731 if Is_Array_Type (Left_Typ) 3732 and then Left_Typ /= Any_Composite 3733 and then Number_Dimensions (Left_Typ) = 1 3734 and then Nkind (N) in N_Op_Eq | N_Op_Ne 3735 then 3736 if Raises_Constraint_Error (Left) 3737 or else 3738 Raises_Constraint_Error (Right) 3739 then 3740 return; 3741 end if; 3742 3743 -- OK, we have the case where we may be able to do this fold 3744 3745 Left_Len := Static_Length (Left); 3746 Right_Len := Static_Length (Right); 3747 3748 if Left_Len /= Uint_Minus_1 3749 and then Right_Len /= Uint_Minus_1 3750 and then Left_Len /= Right_Len 3751 then 3752 -- AI12-0201: comparison of string is static in Ada 202x 3753 3754 Fold_Uint 3755 (N, 3756 Test (Nkind (N) = N_Op_Ne), 3757 Static => Ada_Version >= Ada_2020 3758 and then Is_String_Type (Left_Typ)); 3759 Warn_On_Known_Condition (N); 3760 return; 3761 end if; 3762 end if; 3763 3764 -- General case 3765 3766 -- Initialize the value of Is_Static_Expression. The value of Fold 3767 -- returned by Test_Expression_Is_Foldable is not needed since, even 3768 -- when some operand is a variable, we can still perform the static 3769 -- evaluation of the expression in some cases (for example, for a 3770 -- variable of a subtype of Integer we statically know that any value 3771 -- stored in such variable is smaller than Integer'Last). 3772 3773 Test_Expression_Is_Foldable 3774 (N, Left, Right, Is_Static_Expression, Fold); 3775 3776 -- Comparisons of scalars can give static results. 3777 -- In addition starting with Ada 202x (AI12-0201), comparison of strings 3778 -- can also give static results, and as noted above, we also allow for 3779 -- earlier Ada versions internally generated equality and inequality for 3780 -- strings. 3781 -- ??? The Comes_From_Source test below isn't correct and will accept 3782 -- some cases that are illegal in Ada 2012. and before. Now that Ada 3783 -- 202x has relaxed the rules, this doesn't really matter. 3784 3785 if Is_String_Type (Left_Typ) then 3786 if Ada_Version < Ada_2020 3787 and then (Comes_From_Source (N) 3788 or else Nkind (N) not in N_Op_Eq | N_Op_Ne) 3789 then 3790 Is_Static_Expression := False; 3791 Set_Is_Static_Expression (N, False); 3792 end if; 3793 3794 elsif not Is_Scalar_Type (Left_Typ) then 3795 Is_Static_Expression := False; 3796 Set_Is_Static_Expression (N, False); 3797 end if; 3798 3799 -- For operators on universal numeric types called as functions with an 3800 -- explicit scope, determine appropriate specific numeric type, and 3801 -- diagnose possible ambiguity. 3802 3803 if Is_Universal_Numeric_Type (Left_Typ) 3804 and then 3805 Is_Universal_Numeric_Type (Right_Typ) 3806 then 3807 Op_Typ := Find_Universal_Operator_Type (N); 3808 end if; 3809 3810 -- Attempt to fold the relational operator 3811 3812 if Is_Static_Expression and then Is_Real_Type (Left_Typ) then 3813 Fold_Static_Real_Op; 3814 else 3815 Fold_General_Op (Is_Static_Expression); 3816 end if; 3817 3818 -- For the case of a folded relational operator on a specific numeric 3819 -- type, freeze the operand type now. 3820 3821 if Present (Op_Typ) then 3822 Freeze_Before (N, Op_Typ); 3823 end if; 3824 3825 Warn_On_Known_Condition (N); 3826 end Eval_Relational_Op; 3827 3828 ----------------------------- 3829 -- Eval_Selected_Component -- 3830 ----------------------------- 3831 3832 procedure Eval_Selected_Component (N : Node_Id) is 3833 begin 3834 -- If an attribute reference or a LHS, nothing to do. 3835 -- Also do not fold if N is an [in] out subprogram parameter. 3836 -- Fold will perform the other relevant tests. 3837 3838 if Nkind (Parent (N)) /= N_Attribute_Reference 3839 and then Is_LHS (N) = No 3840 and then not Is_Actual_Out_Or_In_Out_Parameter (N) 3841 then 3842 Fold (N); 3843 end if; 3844 end Eval_Selected_Component; 3845 3846 ---------------- 3847 -- Eval_Shift -- 3848 ---------------- 3849 3850 procedure Eval_Shift (N : Node_Id) is 3851 begin 3852 -- This procedure is only called for compiler generated code (e.g. 3853 -- packed arrays), so there is nothing to do except attempting to fold 3854 -- the expression. 3855 3856 Fold_Shift (N, Left_Opnd (N), Right_Opnd (N), Nkind (N)); 3857 end Eval_Shift; 3858 3859 ------------------------ 3860 -- Eval_Short_Circuit -- 3861 ------------------------ 3862 3863 -- A short circuit operation is potentially static if both operands are 3864 -- potentially static (RM 4.9 (13)). 3865 3866 procedure Eval_Short_Circuit (N : Node_Id) is 3867 Kind : constant Node_Kind := Nkind (N); 3868 Left : constant Node_Id := Left_Opnd (N); 3869 Right : constant Node_Id := Right_Opnd (N); 3870 Left_Int : Uint; 3871 3872 Rstat : constant Boolean := 3873 Is_Static_Expression (Left) 3874 and then 3875 Is_Static_Expression (Right); 3876 3877 begin 3878 -- Short circuit operations are never static in Ada 83 3879 3880 if Ada_Version = Ada_83 and then Comes_From_Source (N) then 3881 Check_Non_Static_Context (Left); 3882 Check_Non_Static_Context (Right); 3883 return; 3884 end if; 3885 3886 -- Now look at the operands, we can't quite use the normal call to 3887 -- Test_Expression_Is_Foldable here because short circuit operations 3888 -- are a special case, they can still be foldable, even if the right 3889 -- operand raises Constraint_Error. 3890 3891 -- If either operand is Any_Type, just propagate to result and do not 3892 -- try to fold, this prevents cascaded errors. 3893 3894 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then 3895 Set_Etype (N, Any_Type); 3896 return; 3897 3898 -- If left operand raises Constraint_Error, then replace node N with 3899 -- the raise Constraint_Error node, and we are obviously not foldable. 3900 -- Is_Static_Expression is set from the two operands in the normal way, 3901 -- and we check the right operand if it is in a non-static context. 3902 3903 elsif Raises_Constraint_Error (Left) then 3904 if not Rstat then 3905 Check_Non_Static_Context (Right); 3906 end if; 3907 3908 Rewrite_In_Raise_CE (N, Left); 3909 Set_Is_Static_Expression (N, Rstat); 3910 return; 3911 3912 -- If the result is not static, then we won't in any case fold 3913 3914 elsif not Rstat then 3915 Check_Non_Static_Context (Left); 3916 Check_Non_Static_Context (Right); 3917 return; 3918 end if; 3919 3920 -- Here the result is static, note that, unlike the normal processing 3921 -- in Test_Expression_Is_Foldable, we did *not* check above to see if 3922 -- the right operand raises Constraint_Error, that's because it is not 3923 -- significant if the left operand is decisive. 3924 3925 Set_Is_Static_Expression (N); 3926 3927 -- It does not matter if the right operand raises Constraint_Error if 3928 -- it will not be evaluated. So deal specially with the cases where 3929 -- the right operand is not evaluated. Note that we will fold these 3930 -- cases even if the right operand is non-static, which is fine, but 3931 -- of course in these cases the result is not potentially static. 3932 3933 Left_Int := Expr_Value (Left); 3934 3935 if (Kind = N_And_Then and then Is_False (Left_Int)) 3936 or else 3937 (Kind = N_Or_Else and then Is_True (Left_Int)) 3938 then 3939 Fold_Uint (N, Left_Int, Rstat); 3940 return; 3941 end if; 3942 3943 -- If first operand not decisive, then it does matter if the right 3944 -- operand raises Constraint_Error, since it will be evaluated, so 3945 -- we simply replace the node with the right operand. Note that this 3946 -- properly propagates Is_Static_Expression and Raises_Constraint_Error 3947 -- (both are set to True in Right). 3948 3949 if Raises_Constraint_Error (Right) then 3950 Rewrite_In_Raise_CE (N, Right); 3951 Check_Non_Static_Context (Left); 3952 return; 3953 end if; 3954 3955 -- Otherwise the result depends on the right operand 3956 3957 Fold_Uint (N, Expr_Value (Right), Rstat); 3958 return; 3959 end Eval_Short_Circuit; 3960 3961 ---------------- 3962 -- Eval_Slice -- 3963 ---------------- 3964 3965 -- Slices can never be static, so the only processing required is to check 3966 -- for non-static context if an explicit range is given. 3967 3968 procedure Eval_Slice (N : Node_Id) is 3969 Drange : constant Node_Id := Discrete_Range (N); 3970 Name : constant Node_Id := Prefix (N); 3971 3972 begin 3973 if Nkind (Drange) = N_Range then 3974 Check_Non_Static_Context (Low_Bound (Drange)); 3975 Check_Non_Static_Context (High_Bound (Drange)); 3976 end if; 3977 3978 -- A slice of the form A (subtype), when the subtype is the index of 3979 -- the type of A, is redundant, the slice can be replaced with A, and 3980 -- this is worth a warning. 3981 3982 if Is_Entity_Name (Name) then 3983 declare 3984 E : constant Entity_Id := Entity (Name); 3985 T : constant Entity_Id := Etype (E); 3986 3987 begin 3988 if Is_Object (E) 3989 and then Is_Array_Type (T) 3990 and then Is_Entity_Name (Drange) 3991 then 3992 if Is_Entity_Name (Original_Node (First_Index (T))) 3993 and then Entity (Original_Node (First_Index (T))) 3994 = Entity (Drange) 3995 then 3996 if Warn_On_Redundant_Constructs then 3997 Error_Msg_N ("redundant slice denotes whole array?r?", N); 3998 end if; 3999 4000 -- The following might be a useful optimization??? 4001 4002 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N))); 4003 end if; 4004 end if; 4005 end; 4006 end if; 4007 end Eval_Slice; 4008 4009 ------------------------- 4010 -- Eval_String_Literal -- 4011 ------------------------- 4012 4013 procedure Eval_String_Literal (N : Node_Id) is 4014 Typ : constant Entity_Id := Etype (N); 4015 Bas : constant Entity_Id := Base_Type (Typ); 4016 Xtp : Entity_Id; 4017 Len : Nat; 4018 Lo : Node_Id; 4019 4020 begin 4021 -- Nothing to do if error type (handles cases like default expressions 4022 -- or generics where we have not yet fully resolved the type). 4023 4024 if Bas = Any_Type or else Bas = Any_String then 4025 return; 4026 end if; 4027 4028 -- String literals are static if the subtype is static (RM 4.9(2)), so 4029 -- reset the static expression flag (it was set unconditionally in 4030 -- Analyze_String_Literal) if the subtype is non-static. We tell if 4031 -- the subtype is static by looking at the lower bound. 4032 4033 if Ekind (Typ) = E_String_Literal_Subtype then 4034 if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then 4035 Set_Is_Static_Expression (N, False); 4036 return; 4037 end if; 4038 4039 -- Here if Etype of string literal is normal Etype (not yet possible, 4040 -- but may be possible in future). 4041 4042 elsif not Is_OK_Static_Expression 4043 (Type_Low_Bound (Etype (First_Index (Typ)))) 4044 then 4045 Set_Is_Static_Expression (N, False); 4046 return; 4047 end if; 4048 4049 -- If original node was a type conversion, then result if non-static 4050 -- up to Ada 2012. AI12-0201 changes that with Ada 202x. 4051 4052 if Nkind (Original_Node (N)) = N_Type_Conversion 4053 and then Ada_Version <= Ada_2012 4054 then 4055 Set_Is_Static_Expression (N, False); 4056 return; 4057 end if; 4058 4059 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95 4060 -- if its bounds are outside the index base type and this index type is 4061 -- static. This can happen in only two ways. Either the string literal 4062 -- is too long, or it is null, and the lower bound is type'First. Either 4063 -- way it is the upper bound that is out of range of the index type. 4064 4065 if Ada_Version >= Ada_95 then 4066 if Is_Standard_String_Type (Bas) then 4067 Xtp := Standard_Positive; 4068 else 4069 Xtp := Etype (First_Index (Bas)); 4070 end if; 4071 4072 if Ekind (Typ) = E_String_Literal_Subtype then 4073 Lo := String_Literal_Low_Bound (Typ); 4074 else 4075 Lo := Type_Low_Bound (Etype (First_Index (Typ))); 4076 end if; 4077 4078 -- Check for string too long 4079 4080 Len := String_Length (Strval (N)); 4081 4082 if UI_From_Int (Len) > String_Type_Len (Bas) then 4083 4084 -- Issue message. Note that this message is a warning if the 4085 -- string literal is not marked as static (happens in some cases 4086 -- of folding strings known at compile time, but not static). 4087 -- Furthermore in such cases, we reword the message, since there 4088 -- is no string literal in the source program. 4089 4090 if Is_Static_Expression (N) then 4091 Apply_Compile_Time_Constraint_Error 4092 (N, "string literal too long for}", CE_Length_Check_Failed, 4093 Ent => Bas, 4094 Typ => First_Subtype (Bas)); 4095 else 4096 Apply_Compile_Time_Constraint_Error 4097 (N, "string value too long for}", CE_Length_Check_Failed, 4098 Ent => Bas, 4099 Typ => First_Subtype (Bas), 4100 Warn => True); 4101 end if; 4102 4103 -- Test for null string not allowed 4104 4105 elsif Len = 0 4106 and then not Is_Generic_Type (Xtp) 4107 and then 4108 Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp))) 4109 then 4110 -- Same specialization of message 4111 4112 if Is_Static_Expression (N) then 4113 Apply_Compile_Time_Constraint_Error 4114 (N, "null string literal not allowed for}", 4115 CE_Length_Check_Failed, 4116 Ent => Bas, 4117 Typ => First_Subtype (Bas)); 4118 else 4119 Apply_Compile_Time_Constraint_Error 4120 (N, "null string value not allowed for}", 4121 CE_Length_Check_Failed, 4122 Ent => Bas, 4123 Typ => First_Subtype (Bas), 4124 Warn => True); 4125 end if; 4126 end if; 4127 end if; 4128 end Eval_String_Literal; 4129 4130 -------------------------- 4131 -- Eval_Type_Conversion -- 4132 -------------------------- 4133 4134 -- A type conversion is potentially static if its subtype mark is for a 4135 -- static scalar subtype, and its operand expression is potentially static 4136 -- (RM 4.9(10)). 4137 -- Also add support for static string types. 4138 4139 procedure Eval_Type_Conversion (N : Node_Id) is 4140 Operand : constant Node_Id := Expression (N); 4141 Source_Type : constant Entity_Id := Etype (Operand); 4142 Target_Type : constant Entity_Id := Etype (N); 4143 4144 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean; 4145 -- Returns true if type T is an integer type, or if it is a fixed-point 4146 -- type to be treated as an integer (i.e. the flag Conversion_OK is set 4147 -- on the conversion node). 4148 4149 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean; 4150 -- Returns true if type T is a floating-point type, or if it is a 4151 -- fixed-point type that is not to be treated as an integer (i.e. the 4152 -- flag Conversion_OK is not set on the conversion node). 4153 4154 ------------------------------ 4155 -- To_Be_Treated_As_Integer -- 4156 ------------------------------ 4157 4158 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is 4159 begin 4160 return 4161 Is_Integer_Type (T) 4162 or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N)); 4163 end To_Be_Treated_As_Integer; 4164 4165 --------------------------- 4166 -- To_Be_Treated_As_Real -- 4167 --------------------------- 4168 4169 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is 4170 begin 4171 return 4172 Is_Floating_Point_Type (T) 4173 or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N)); 4174 end To_Be_Treated_As_Real; 4175 4176 -- Local variables 4177 4178 Fold : Boolean; 4179 Stat : Boolean; 4180 4181 -- Start of processing for Eval_Type_Conversion 4182 4183 begin 4184 -- Cannot fold if target type is non-static or if semantic error 4185 4186 if not Is_Static_Subtype (Target_Type) then 4187 Check_Non_Static_Context (Operand); 4188 return; 4189 elsif Error_Posted (N) then 4190 return; 4191 end if; 4192 4193 -- If not foldable we are done 4194 4195 Test_Expression_Is_Foldable (N, Operand, Stat, Fold); 4196 4197 if not Fold then 4198 return; 4199 4200 -- Don't try fold if target type has Constraint_Error bounds 4201 4202 elsif not Is_OK_Static_Subtype (Target_Type) then 4203 Set_Raises_Constraint_Error (N); 4204 return; 4205 end if; 4206 4207 -- Remaining processing depends on operand types. Note that in the 4208 -- following type test, fixed-point counts as real unless the flag 4209 -- Conversion_OK is set, in which case it counts as integer. 4210 4211 -- Fold conversion, case of string type. The result is static starting 4212 -- with Ada 202x (AI12-0201). 4213 4214 if Is_String_Type (Target_Type) then 4215 Fold_Str 4216 (N, 4217 Strval (Get_String_Val (Operand)), 4218 Static => Ada_Version >= Ada_2020); 4219 return; 4220 4221 -- Fold conversion, case of integer target type 4222 4223 elsif To_Be_Treated_As_Integer (Target_Type) then 4224 declare 4225 Result : Uint; 4226 4227 begin 4228 -- Integer to integer conversion 4229 4230 if To_Be_Treated_As_Integer (Source_Type) then 4231 Result := Expr_Value (Operand); 4232 4233 -- Real to integer conversion 4234 4235 elsif To_Be_Treated_As_Real (Source_Type) then 4236 Result := UR_To_Uint (Expr_Value_R (Operand)); 4237 4238 -- Enumeration to integer conversion, aka 'Enum_Rep 4239 4240 else 4241 Result := Expr_Rep_Value (Operand); 4242 end if; 4243 4244 -- If fixed-point type (Conversion_OK must be set), then the 4245 -- result is logically an integer, but we must replace the 4246 -- conversion with the corresponding real literal, since the 4247 -- type from a semantic point of view is still fixed-point. 4248 4249 if Is_Fixed_Point_Type (Target_Type) then 4250 Fold_Ureal 4251 (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat); 4252 4253 -- Otherwise result is integer literal 4254 4255 else 4256 Fold_Uint (N, Result, Stat); 4257 end if; 4258 end; 4259 4260 -- Fold conversion, case of real target type 4261 4262 elsif To_Be_Treated_As_Real (Target_Type) then 4263 declare 4264 Result : Ureal; 4265 4266 begin 4267 if To_Be_Treated_As_Real (Source_Type) then 4268 Result := Expr_Value_R (Operand); 4269 else 4270 Result := UR_From_Uint (Expr_Value (Operand)); 4271 end if; 4272 4273 Fold_Ureal (N, Result, Stat); 4274 end; 4275 4276 -- Enumeration types 4277 4278 else 4279 Fold_Uint (N, Expr_Value (Operand), Stat); 4280 end if; 4281 4282 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then 4283 Out_Of_Range (N); 4284 end if; 4285 end Eval_Type_Conversion; 4286 4287 ------------------- 4288 -- Eval_Unary_Op -- 4289 ------------------- 4290 4291 -- Predefined unary operators are static functions (RM 4.9(20)) and thus 4292 -- are potentially static if the operand is potentially static (RM 4.9(7)). 4293 4294 procedure Eval_Unary_Op (N : Node_Id) is 4295 Right : constant Node_Id := Right_Opnd (N); 4296 Otype : Entity_Id := Empty; 4297 Stat : Boolean; 4298 Fold : Boolean; 4299 4300 begin 4301 -- If not foldable we are done 4302 4303 Test_Expression_Is_Foldable (N, Right, Stat, Fold); 4304 4305 if not Fold then 4306 return; 4307 end if; 4308 4309 if Etype (Right) = Universal_Integer 4310 or else 4311 Etype (Right) = Universal_Real 4312 then 4313 Otype := Find_Universal_Operator_Type (N); 4314 end if; 4315 4316 -- Fold for integer case 4317 4318 if Is_Integer_Type (Etype (N)) then 4319 declare 4320 Rint : constant Uint := Expr_Value (Right); 4321 Result : Uint; 4322 4323 begin 4324 -- In the case of modular unary plus and abs there is no need 4325 -- to adjust the result of the operation since if the original 4326 -- operand was in bounds the result will be in the bounds of the 4327 -- modular type. However, in the case of modular unary minus the 4328 -- result may go out of the bounds of the modular type and needs 4329 -- adjustment. 4330 4331 if Nkind (N) = N_Op_Plus then 4332 Result := Rint; 4333 4334 elsif Nkind (N) = N_Op_Minus then 4335 if Is_Modular_Integer_Type (Etype (N)) then 4336 Result := (-Rint) mod Modulus (Etype (N)); 4337 else 4338 Result := (-Rint); 4339 end if; 4340 4341 else 4342 pragma Assert (Nkind (N) = N_Op_Abs); 4343 Result := abs Rint; 4344 end if; 4345 4346 Fold_Uint (N, Result, Stat); 4347 end; 4348 4349 -- Fold for real case 4350 4351 elsif Is_Real_Type (Etype (N)) then 4352 declare 4353 Rreal : constant Ureal := Expr_Value_R (Right); 4354 Result : Ureal; 4355 4356 begin 4357 if Nkind (N) = N_Op_Plus then 4358 Result := Rreal; 4359 elsif Nkind (N) = N_Op_Minus then 4360 Result := UR_Negate (Rreal); 4361 else 4362 pragma Assert (Nkind (N) = N_Op_Abs); 4363 Result := abs Rreal; 4364 end if; 4365 4366 Fold_Ureal (N, Result, Stat); 4367 end; 4368 end if; 4369 4370 -- If the operator was resolved to a specific type, make sure that type 4371 -- is frozen even if the expression is folded into a literal (which has 4372 -- a universal type). 4373 4374 if Present (Otype) then 4375 Freeze_Before (N, Otype); 4376 end if; 4377 end Eval_Unary_Op; 4378 4379 ------------------------------- 4380 -- Eval_Unchecked_Conversion -- 4381 ------------------------------- 4382 4383 -- Unchecked conversions can never be static, so the only required 4384 -- processing is to check for a non-static context for the operand. 4385 4386 procedure Eval_Unchecked_Conversion (N : Node_Id) is 4387 Target_Type : constant Entity_Id := Etype (N); 4388 Operand : constant Node_Id := Expression (N); 4389 Operand_Type : constant Entity_Id := Etype (Operand); 4390 4391 begin 4392 Check_Non_Static_Context (Operand); 4393 4394 -- If we have a conversion of a compile time known value to a target 4395 -- type and the value is in range of the target type, then we can simply 4396 -- replace the construct by an integer literal of the correct type. We 4397 -- only apply this to discrete types being converted. Possibly it may 4398 -- apply in other cases, but it is too much trouble to worry about. 4399 4400 -- Note that we do not do this transformation if the Kill_Range_Check 4401 -- flag is set, since then the value may be outside the expected range. 4402 -- This happens in the Normalize_Scalars case. 4403 4404 -- We also skip this if either the target or operand type is biased 4405 -- because in this case, the unchecked conversion is supposed to 4406 -- preserve the bit pattern, not the integer value. 4407 4408 if Is_Integer_Type (Target_Type) 4409 and then not Has_Biased_Representation (Target_Type) 4410 and then Is_Discrete_Type (Operand_Type) 4411 and then not Has_Biased_Representation (Operand_Type) 4412 and then Compile_Time_Known_Value (Operand) 4413 and then not Kill_Range_Check (N) 4414 then 4415 declare 4416 Val : constant Uint := Expr_Rep_Value (Operand); 4417 4418 begin 4419 if Compile_Time_Known_Value (Type_Low_Bound (Target_Type)) 4420 and then 4421 Compile_Time_Known_Value (Type_High_Bound (Target_Type)) 4422 and then 4423 Val >= Expr_Value (Type_Low_Bound (Target_Type)) 4424 and then 4425 Val <= Expr_Value (Type_High_Bound (Target_Type)) 4426 then 4427 Rewrite (N, Make_Integer_Literal (Sloc (N), Val)); 4428 4429 -- If Address is the target type, just set the type to avoid a 4430 -- spurious type error on the literal when Address is a visible 4431 -- integer type. 4432 4433 if Is_Descendant_Of_Address (Target_Type) then 4434 Set_Etype (N, Target_Type); 4435 else 4436 Analyze_And_Resolve (N, Target_Type); 4437 end if; 4438 4439 return; 4440 end if; 4441 end; 4442 end if; 4443 end Eval_Unchecked_Conversion; 4444 4445 -------------------- 4446 -- Expr_Rep_Value -- 4447 -------------------- 4448 4449 function Expr_Rep_Value (N : Node_Id) return Uint is 4450 Kind : constant Node_Kind := Nkind (N); 4451 Ent : Entity_Id; 4452 4453 begin 4454 if Is_Entity_Name (N) then 4455 Ent := Entity (N); 4456 4457 -- An enumeration literal that was either in the source or created 4458 -- as a result of static evaluation. 4459 4460 if Ekind (Ent) = E_Enumeration_Literal then 4461 return Enumeration_Rep (Ent); 4462 4463 -- A user defined static constant 4464 4465 else 4466 pragma Assert (Ekind (Ent) = E_Constant); 4467 return Expr_Rep_Value (Constant_Value (Ent)); 4468 end if; 4469 4470 -- An integer literal that was either in the source or created as a 4471 -- result of static evaluation. 4472 4473 elsif Kind = N_Integer_Literal then 4474 return Intval (N); 4475 4476 -- A real literal for a fixed-point type. This must be the fixed-point 4477 -- case, either the literal is of a fixed-point type, or it is a bound 4478 -- of a fixed-point type, with type universal real. In either case we 4479 -- obtain the desired value from Corresponding_Integer_Value. 4480 4481 elsif Kind = N_Real_Literal then 4482 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N)))); 4483 return Corresponding_Integer_Value (N); 4484 4485 -- The NULL access value 4486 4487 elsif Kind = N_Null then 4488 pragma Assert (Is_Access_Type (Underlying_Type (Etype (N))) 4489 or else Error_Posted (N)); 4490 return Uint_0; 4491 4492 -- Character literal 4493 4494 elsif Kind = N_Character_Literal then 4495 Ent := Entity (N); 4496 4497 -- Since Character literals of type Standard.Character don't have any 4498 -- defining character literals built for them, they do not have their 4499 -- Entity set, so just use their Char code. Otherwise for user- 4500 -- defined character literals use their Pos value as usual which is 4501 -- the same as the Rep value. 4502 4503 if No (Ent) then 4504 return Char_Literal_Value (N); 4505 else 4506 return Enumeration_Rep (Ent); 4507 end if; 4508 4509 -- Unchecked conversion, which can come from System'To_Address (X) 4510 -- where X is a static integer expression. Recursively evaluate X. 4511 4512 elsif Kind = N_Unchecked_Type_Conversion then 4513 return Expr_Rep_Value (Expression (N)); 4514 4515 -- Static discriminant value 4516 4517 elsif Is_Static_Discriminant_Component (N) then 4518 return Expr_Rep_Value 4519 (Get_Discriminant_Value 4520 (Entity (Selector_Name (N)), 4521 Etype (Prefix (N)), 4522 Discriminant_Constraint (Etype (Prefix (N))))); 4523 4524 else 4525 raise Program_Error; 4526 end if; 4527 end Expr_Rep_Value; 4528 4529 ---------------- 4530 -- Expr_Value -- 4531 ---------------- 4532 4533 function Expr_Value (N : Node_Id) return Uint is 4534 Kind : constant Node_Kind := Nkind (N); 4535 CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size); 4536 Ent : Entity_Id; 4537 Val : Uint; 4538 4539 begin 4540 -- If already in cache, then we know it's compile-time-known and we can 4541 -- return the value that was previously stored in the cache since 4542 -- compile-time-known values cannot change. 4543 4544 if CV_Ent.N = N then 4545 return CV_Ent.V; 4546 end if; 4547 4548 -- Otherwise proceed to test value 4549 4550 if Is_Entity_Name (N) then 4551 Ent := Entity (N); 4552 4553 -- An enumeration literal that was either in the source or created as 4554 -- a result of static evaluation. 4555 4556 if Ekind (Ent) = E_Enumeration_Literal then 4557 Val := Enumeration_Pos (Ent); 4558 4559 -- A user defined static constant 4560 4561 else 4562 pragma Assert (Ekind (Ent) = E_Constant); 4563 Val := Expr_Value (Constant_Value (Ent)); 4564 end if; 4565 4566 -- An integer literal that was either in the source or created as a 4567 -- result of static evaluation. 4568 4569 elsif Kind = N_Integer_Literal then 4570 Val := Intval (N); 4571 4572 -- A real literal for a fixed-point type. This must be the fixed-point 4573 -- case, either the literal is of a fixed-point type, or it is a bound 4574 -- of a fixed-point type, with type universal real. In either case we 4575 -- obtain the desired value from Corresponding_Integer_Value. 4576 4577 elsif Kind = N_Real_Literal then 4578 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N)))); 4579 Val := Corresponding_Integer_Value (N); 4580 4581 -- The NULL access value 4582 4583 elsif Kind = N_Null then 4584 pragma Assert (Is_Access_Type (Underlying_Type (Etype (N))) 4585 or else Error_Posted (N)); 4586 Val := Uint_0; 4587 4588 -- Character literal 4589 4590 elsif Kind = N_Character_Literal then 4591 Ent := Entity (N); 4592 4593 -- Since Character literals of type Standard.Character don't 4594 -- have any defining character literals built for them, they 4595 -- do not have their Entity set, so just use their Char 4596 -- code. Otherwise for user-defined character literals use 4597 -- their Pos value as usual. 4598 4599 if No (Ent) then 4600 Val := Char_Literal_Value (N); 4601 else 4602 Val := Enumeration_Pos (Ent); 4603 end if; 4604 4605 -- Unchecked conversion, which can come from System'To_Address (X) 4606 -- where X is a static integer expression. Recursively evaluate X. 4607 4608 elsif Kind = N_Unchecked_Type_Conversion then 4609 Val := Expr_Value (Expression (N)); 4610 4611 -- Static discriminant value 4612 4613 elsif Is_Static_Discriminant_Component (N) then 4614 Val := Expr_Value 4615 (Get_Discriminant_Value 4616 (Entity (Selector_Name (N)), 4617 Etype (Prefix (N)), 4618 Discriminant_Constraint (Etype (Prefix (N))))); 4619 4620 else 4621 raise Program_Error; 4622 end if; 4623 4624 -- Come here with Val set to value to be returned, set cache 4625 4626 CV_Ent.N := N; 4627 CV_Ent.V := Val; 4628 return Val; 4629 end Expr_Value; 4630 4631 ------------------ 4632 -- Expr_Value_E -- 4633 ------------------ 4634 4635 function Expr_Value_E (N : Node_Id) return Entity_Id is 4636 Ent : constant Entity_Id := Entity (N); 4637 begin 4638 if Ekind (Ent) = E_Enumeration_Literal then 4639 return Ent; 4640 else 4641 pragma Assert (Ekind (Ent) = E_Constant); 4642 4643 -- We may be dealing with a enumerated character type constant, so 4644 -- handle that case here. 4645 4646 if Nkind (Constant_Value (Ent)) = N_Character_Literal then 4647 return Ent; 4648 else 4649 return Expr_Value_E (Constant_Value (Ent)); 4650 end if; 4651 end if; 4652 end Expr_Value_E; 4653 4654 ------------------ 4655 -- Expr_Value_R -- 4656 ------------------ 4657 4658 function Expr_Value_R (N : Node_Id) return Ureal is 4659 Kind : constant Node_Kind := Nkind (N); 4660 Ent : Entity_Id; 4661 4662 begin 4663 if Kind = N_Real_Literal then 4664 return Realval (N); 4665 4666 elsif Kind = N_Identifier or else Kind = N_Expanded_Name then 4667 Ent := Entity (N); 4668 pragma Assert (Ekind (Ent) = E_Constant); 4669 return Expr_Value_R (Constant_Value (Ent)); 4670 4671 elsif Kind = N_Integer_Literal then 4672 return UR_From_Uint (Expr_Value (N)); 4673 4674 -- Here, we have a node that cannot be interpreted as a compile time 4675 -- constant. That is definitely an error. 4676 4677 else 4678 raise Program_Error; 4679 end if; 4680 end Expr_Value_R; 4681 4682 ------------------ 4683 -- Expr_Value_S -- 4684 ------------------ 4685 4686 function Expr_Value_S (N : Node_Id) return Node_Id is 4687 begin 4688 if Nkind (N) = N_String_Literal then 4689 return N; 4690 else 4691 pragma Assert (Ekind (Entity (N)) = E_Constant); 4692 return Expr_Value_S (Constant_Value (Entity (N))); 4693 end if; 4694 end Expr_Value_S; 4695 4696 ---------------------------------- 4697 -- Find_Universal_Operator_Type -- 4698 ---------------------------------- 4699 4700 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is 4701 PN : constant Node_Id := Parent (N); 4702 Call : constant Node_Id := Original_Node (N); 4703 Is_Int : constant Boolean := Is_Integer_Type (Etype (N)); 4704 4705 Is_Fix : constant Boolean := 4706 Nkind (N) in N_Binary_Op 4707 and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N)); 4708 -- A mixed-mode operation in this context indicates the presence of 4709 -- fixed-point type in the designated package. 4710 4711 Is_Relational : constant Boolean := Etype (N) = Standard_Boolean; 4712 -- Case where N is a relational (or membership) operator (else it is an 4713 -- arithmetic one). 4714 4715 In_Membership : constant Boolean := 4716 Nkind (PN) in N_Membership_Test 4717 and then 4718 Nkind (Right_Opnd (PN)) = N_Range 4719 and then 4720 Is_Universal_Numeric_Type (Etype (Left_Opnd (PN))) 4721 and then 4722 Is_Universal_Numeric_Type 4723 (Etype (Low_Bound (Right_Opnd (PN)))) 4724 and then 4725 Is_Universal_Numeric_Type 4726 (Etype (High_Bound (Right_Opnd (PN)))); 4727 -- Case where N is part of a membership test with a universal range 4728 4729 E : Entity_Id; 4730 Pack : Entity_Id; 4731 Typ1 : Entity_Id := Empty; 4732 Priv_E : Entity_Id; 4733 4734 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean; 4735 -- Check whether one operand is a mixed-mode operation that requires the 4736 -- presence of a fixed-point type. Given that all operands are universal 4737 -- and have been constant-folded, retrieve the original function call. 4738 4739 --------------------------- 4740 -- Is_Mixed_Mode_Operand -- 4741 --------------------------- 4742 4743 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is 4744 Onod : constant Node_Id := Original_Node (Op); 4745 begin 4746 return Nkind (Onod) = N_Function_Call 4747 and then Present (Next_Actual (First_Actual (Onod))) 4748 and then Etype (First_Actual (Onod)) /= 4749 Etype (Next_Actual (First_Actual (Onod))); 4750 end Is_Mixed_Mode_Operand; 4751 4752 -- Start of processing for Find_Universal_Operator_Type 4753 4754 begin 4755 if Nkind (Call) /= N_Function_Call 4756 or else Nkind (Name (Call)) /= N_Expanded_Name 4757 then 4758 return Empty; 4759 4760 -- There are several cases where the context does not imply the type of 4761 -- the operands: 4762 -- - the universal expression appears in a type conversion; 4763 -- - the expression is a relational operator applied to universal 4764 -- operands; 4765 -- - the expression is a membership test with a universal operand 4766 -- and a range with universal bounds. 4767 4768 elsif Nkind (Parent (N)) = N_Type_Conversion 4769 or else Is_Relational 4770 or else In_Membership 4771 then 4772 Pack := Entity (Prefix (Name (Call))); 4773 4774 -- If the prefix is a package declared elsewhere, iterate over its 4775 -- visible entities, otherwise iterate over all declarations in the 4776 -- designated scope. 4777 4778 if Ekind (Pack) = E_Package 4779 and then not In_Open_Scopes (Pack) 4780 then 4781 Priv_E := First_Private_Entity (Pack); 4782 else 4783 Priv_E := Empty; 4784 end if; 4785 4786 Typ1 := Empty; 4787 E := First_Entity (Pack); 4788 while Present (E) and then E /= Priv_E loop 4789 if Is_Numeric_Type (E) 4790 and then Nkind (Parent (E)) /= N_Subtype_Declaration 4791 and then Comes_From_Source (E) 4792 and then Is_Integer_Type (E) = Is_Int 4793 and then (Nkind (N) in N_Unary_Op 4794 or else Is_Relational 4795 or else Is_Fixed_Point_Type (E) = Is_Fix) 4796 then 4797 if No (Typ1) then 4798 Typ1 := E; 4799 4800 -- Before emitting an error, check for the presence of a 4801 -- mixed-mode operation that specifies a fixed point type. 4802 4803 elsif Is_Relational 4804 and then 4805 (Is_Mixed_Mode_Operand (Left_Opnd (N)) 4806 or else Is_Mixed_Mode_Operand (Right_Opnd (N))) 4807 and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1) 4808 4809 then 4810 if Is_Fixed_Point_Type (E) then 4811 Typ1 := E; 4812 end if; 4813 4814 else 4815 -- More than one type of the proper class declared in P 4816 4817 Error_Msg_N ("ambiguous operation", N); 4818 Error_Msg_Sloc := Sloc (Typ1); 4819 Error_Msg_N ("\possible interpretation (inherited)#", N); 4820 Error_Msg_Sloc := Sloc (E); 4821 Error_Msg_N ("\possible interpretation (inherited)#", N); 4822 return Empty; 4823 end if; 4824 end if; 4825 4826 Next_Entity (E); 4827 end loop; 4828 end if; 4829 4830 return Typ1; 4831 end Find_Universal_Operator_Type; 4832 4833 -------------------------- 4834 -- Flag_Non_Static_Expr -- 4835 -------------------------- 4836 4837 procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is 4838 begin 4839 if Error_Posted (Expr) and then not All_Errors_Mode then 4840 return; 4841 else 4842 Error_Msg_F (Msg, Expr); 4843 Why_Not_Static (Expr); 4844 end if; 4845 end Flag_Non_Static_Expr; 4846 4847 ---------- 4848 -- Fold -- 4849 ---------- 4850 4851 procedure Fold (N : Node_Id) is 4852 Typ : constant Entity_Id := Etype (N); 4853 begin 4854 -- If not known at compile time or if already a literal, nothing to do 4855 4856 if Nkind (N) in N_Numeric_Or_String_Literal 4857 or else not Compile_Time_Known_Value (N) 4858 then 4859 null; 4860 4861 elsif Is_Discrete_Type (Typ) then 4862 Fold_Uint (N, Expr_Value (N), Static => Is_Static_Expression (N)); 4863 4864 elsif Is_Real_Type (Typ) then 4865 Fold_Ureal (N, Expr_Value_R (N), Static => Is_Static_Expression (N)); 4866 4867 elsif Is_String_Type (Typ) then 4868 Fold_Str 4869 (N, Strval (Expr_Value_S (N)), Static => Is_Static_Expression (N)); 4870 end if; 4871 end Fold; 4872 4873 ---------------- 4874 -- Fold_Dummy -- 4875 ---------------- 4876 4877 procedure Fold_Dummy (N : Node_Id; Typ : Entity_Id) is 4878 begin 4879 if Is_Integer_Type (Typ) then 4880 Fold_Uint (N, Uint_1, Static => True); 4881 4882 elsif Is_Real_Type (Typ) then 4883 Fold_Ureal (N, Ureal_1, Static => True); 4884 4885 elsif Is_Enumeration_Type (Typ) then 4886 Fold_Uint 4887 (N, 4888 Expr_Value (Type_Low_Bound (Base_Type (Typ))), 4889 Static => True); 4890 4891 elsif Is_String_Type (Typ) then 4892 Fold_Str 4893 (N, 4894 Strval (Make_String_Literal (Sloc (N), "")), 4895 Static => True); 4896 end if; 4897 end Fold_Dummy; 4898 4899 ---------------- 4900 -- Fold_Shift -- 4901 ---------------- 4902 4903 procedure Fold_Shift 4904 (N : Node_Id; 4905 Left : Node_Id; 4906 Right : Node_Id; 4907 Op : Node_Kind; 4908 Static : Boolean := False; 4909 Check_Elab : Boolean := False) 4910 is 4911 Typ : constant Entity_Id := Base_Type (Etype (Left)); 4912 4913 procedure Check_Elab_Call; 4914 -- Add checks related to calls in elaboration code 4915 4916 --------------------- 4917 -- Check_Elab_Call -- 4918 --------------------- 4919 4920 procedure Check_Elab_Call is 4921 begin 4922 if Check_Elab then 4923 if Legacy_Elaboration_Checks then 4924 Check_Elab_Call (N); 4925 end if; 4926 4927 Build_Call_Marker (N); 4928 end if; 4929 end Check_Elab_Call; 4930 4931 Modulus : Uint; 4932 4933 begin 4934 if Compile_Time_Known_Value (Left) 4935 and then Compile_Time_Known_Value (Right) 4936 then 4937 pragma Assert (not Non_Binary_Modulus (Typ)); 4938 4939 if Op = N_Op_Shift_Left then 4940 Check_Elab_Call; 4941 4942 declare 4943 Modulus : Uint; 4944 begin 4945 if Is_Modular_Integer_Type (Typ) then 4946 Modulus := Einfo.Modulus (Typ); 4947 else 4948 Modulus := Uint_2 ** RM_Size (Typ); 4949 end if; 4950 4951 -- Fold Shift_Left (X, Y) by computing (X * 2**Y) rem modulus 4952 4953 Fold_Uint 4954 (N, 4955 (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right))) 4956 rem Modulus, 4957 Static => Static); 4958 end; 4959 4960 elsif Op = N_Op_Shift_Right then 4961 Check_Elab_Call; 4962 4963 -- X >> 0 is a no-op 4964 4965 if Expr_Value (Right) = Uint_0 then 4966 Fold_Uint (N, Expr_Value (Left), Static => Static); 4967 else 4968 if Is_Modular_Integer_Type (Typ) then 4969 Modulus := Einfo.Modulus (Typ); 4970 else 4971 Modulus := Uint_2 ** RM_Size (Typ); 4972 end if; 4973 4974 -- Fold X >> Y by computing (X [+ Modulus]) / 2**Y 4975 -- Note that after a Shift_Right operation (with Y > 0), the 4976 -- result is always positive, even if the original operand was 4977 -- negative. 4978 4979 Fold_Uint 4980 (N, 4981 (Expr_Value (Left) + 4982 (if Expr_Value (Left) >= Uint_0 then Uint_0 else Modulus)) 4983 / (Uint_2 ** Expr_Value (Right)), 4984 Static => Static); 4985 end if; 4986 elsif Op = N_Op_Shift_Right_Arithmetic then 4987 Check_Elab_Call; 4988 4989 declare 4990 Two_Y : constant Uint := Uint_2 ** Expr_Value (Right); 4991 begin 4992 if Is_Modular_Integer_Type (Typ) then 4993 Modulus := Einfo.Modulus (Typ); 4994 else 4995 Modulus := Uint_2 ** RM_Size (Typ); 4996 end if; 4997 4998 -- X / 2**Y if X if positive or a small enough modular integer 4999 5000 if (Is_Modular_Integer_Type (Typ) 5001 and then Expr_Value (Left) < Modulus / Uint_2) 5002 or else 5003 (not Is_Modular_Integer_Type (Typ) 5004 and then Expr_Value (Left) >= 0) 5005 then 5006 Fold_Uint (N, Expr_Value (Left) / Two_Y, Static => Static); 5007 5008 -- -1 (aka all 1's) if Y is larger than the number of bits 5009 -- available or if X = -1. 5010 5011 elsif Two_Y > Modulus 5012 or else Expr_Value (Left) = Uint_Minus_1 5013 then 5014 if Is_Modular_Integer_Type (Typ) then 5015 Fold_Uint (N, Modulus - Uint_1, Static => Static); 5016 else 5017 Fold_Uint (N, Uint_Minus_1, Static => Static); 5018 end if; 5019 5020 -- Large modular integer, compute via multiply/divide the 5021 -- following: X >> Y + (1 << Y - 1) << (RM_Size - Y) 5022 5023 elsif Is_Modular_Integer_Type (Typ) then 5024 Fold_Uint 5025 (N, 5026 (Expr_Value (Left)) / Two_Y 5027 + (Two_Y - Uint_1) 5028 * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right)), 5029 Static => Static); 5030 5031 -- Negative signed integer, compute via multiple/divide the 5032 -- following: 5033 -- (Modulus + X) >> Y + (1 << Y - 1) << (RM_Size - Y) - Modulus 5034 5035 else 5036 Fold_Uint 5037 (N, 5038 (Modulus + Expr_Value (Left)) / Two_Y 5039 + (Two_Y - Uint_1) 5040 * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right)) 5041 - Modulus, 5042 Static => Static); 5043 end if; 5044 end; 5045 end if; 5046 end if; 5047 end Fold_Shift; 5048 5049 -------------- 5050 -- Fold_Str -- 5051 -------------- 5052 5053 procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is 5054 Loc : constant Source_Ptr := Sloc (N); 5055 Typ : constant Entity_Id := Etype (N); 5056 5057 begin 5058 if Raises_Constraint_Error (N) then 5059 Set_Is_Static_Expression (N, Static); 5060 return; 5061 end if; 5062 5063 Rewrite (N, Make_String_Literal (Loc, Strval => Val)); 5064 5065 -- We now have the literal with the right value, both the actual type 5066 -- and the expected type of this literal are taken from the expression 5067 -- that was evaluated. So now we do the Analyze and Resolve. 5068 5069 -- Note that we have to reset Is_Static_Expression both after the 5070 -- analyze step (because Resolve will evaluate the literal, which 5071 -- will cause semantic errors if it is marked as static), and after 5072 -- the Resolve step (since Resolve in some cases resets this flag). 5073 5074 Analyze (N); 5075 Set_Is_Static_Expression (N, Static); 5076 Set_Etype (N, Typ); 5077 Resolve (N); 5078 Set_Is_Static_Expression (N, Static); 5079 end Fold_Str; 5080 5081 --------------- 5082 -- Fold_Uint -- 5083 --------------- 5084 5085 procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is 5086 Loc : constant Source_Ptr := Sloc (N); 5087 Typ : Entity_Id := Etype (N); 5088 Ent : Entity_Id; 5089 5090 begin 5091 if Raises_Constraint_Error (N) then 5092 Set_Is_Static_Expression (N, Static); 5093 return; 5094 end if; 5095 5096 -- If we are folding a named number, retain the entity in the literal 5097 -- in the original tree. 5098 5099 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer then 5100 Ent := Entity (N); 5101 else 5102 Ent := Empty; 5103 end if; 5104 5105 if Is_Private_Type (Typ) then 5106 Typ := Full_View (Typ); 5107 end if; 5108 5109 -- For a result of type integer, substitute an N_Integer_Literal node 5110 -- for the result of the compile time evaluation of the expression. 5111 -- Set a link to the original named number when not in a generic context 5112 -- for reference in the original tree. 5113 5114 if Is_Integer_Type (Typ) then 5115 Rewrite (N, Make_Integer_Literal (Loc, Val)); 5116 Set_Original_Entity (N, Ent); 5117 5118 -- Otherwise we have an enumeration type, and we substitute either 5119 -- an N_Identifier or N_Character_Literal to represent the enumeration 5120 -- literal corresponding to the given value, which must always be in 5121 -- range, because appropriate tests have already been made for this. 5122 5123 else pragma Assert (Is_Enumeration_Type (Typ)); 5124 Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc)); 5125 end if; 5126 5127 -- We now have the literal with the right value, both the actual type 5128 -- and the expected type of this literal are taken from the expression 5129 -- that was evaluated. So now we do the Analyze and Resolve. 5130 5131 -- Note that we have to reset Is_Static_Expression both after the 5132 -- analyze step (because Resolve will evaluate the literal, which 5133 -- will cause semantic errors if it is marked as static), and after 5134 -- the Resolve step (since Resolve in some cases sets this flag). 5135 5136 Analyze (N); 5137 Set_Is_Static_Expression (N, Static); 5138 Set_Etype (N, Typ); 5139 Resolve (N); 5140 Set_Is_Static_Expression (N, Static); 5141 end Fold_Uint; 5142 5143 ---------------- 5144 -- Fold_Ureal -- 5145 ---------------- 5146 5147 procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is 5148 Loc : constant Source_Ptr := Sloc (N); 5149 Typ : constant Entity_Id := Etype (N); 5150 Ent : Entity_Id; 5151 5152 begin 5153 if Raises_Constraint_Error (N) then 5154 Set_Is_Static_Expression (N, Static); 5155 return; 5156 end if; 5157 5158 -- If we are folding a named number, retain the entity in the literal 5159 -- in the original tree. 5160 5161 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real then 5162 Ent := Entity (N); 5163 else 5164 Ent := Empty; 5165 end if; 5166 5167 Rewrite (N, Make_Real_Literal (Loc, Realval => Val)); 5168 5169 -- Set link to original named number 5170 5171 Set_Original_Entity (N, Ent); 5172 5173 -- We now have the literal with the right value, both the actual type 5174 -- and the expected type of this literal are taken from the expression 5175 -- that was evaluated. So now we do the Analyze and Resolve. 5176 5177 -- Note that we have to reset Is_Static_Expression both after the 5178 -- analyze step (because Resolve will evaluate the literal, which 5179 -- will cause semantic errors if it is marked as static), and after 5180 -- the Resolve step (since Resolve in some cases sets this flag). 5181 5182 -- We mark the node as analyzed so that its type is not erased by 5183 -- calling Analyze_Real_Literal. 5184 5185 Analyze (N); 5186 Set_Is_Static_Expression (N, Static); 5187 Set_Etype (N, Typ); 5188 Resolve (N); 5189 Set_Analyzed (N); 5190 Set_Is_Static_Expression (N, Static); 5191 end Fold_Ureal; 5192 5193 --------------- 5194 -- From_Bits -- 5195 --------------- 5196 5197 function From_Bits (B : Bits; T : Entity_Id) return Uint is 5198 V : Uint := Uint_0; 5199 5200 begin 5201 for J in 0 .. B'Last loop 5202 if B (J) then 5203 V := V + 2 ** J; 5204 end if; 5205 end loop; 5206 5207 if Non_Binary_Modulus (T) then 5208 V := V mod Modulus (T); 5209 end if; 5210 5211 return V; 5212 end From_Bits; 5213 5214 -------------------- 5215 -- Get_String_Val -- 5216 -------------------- 5217 5218 function Get_String_Val (N : Node_Id) return Node_Id is 5219 begin 5220 if Nkind (N) in N_String_Literal | N_Character_Literal then 5221 return N; 5222 else 5223 pragma Assert (Is_Entity_Name (N)); 5224 return Get_String_Val (Constant_Value (Entity (N))); 5225 end if; 5226 end Get_String_Val; 5227 5228 ---------------- 5229 -- Initialize -- 5230 ---------------- 5231 5232 procedure Initialize is 5233 begin 5234 CV_Cache := (others => (Node_High_Bound, Uint_0)); 5235 end Initialize; 5236 5237 -------------------- 5238 -- In_Subrange_Of -- 5239 -------------------- 5240 5241 function In_Subrange_Of 5242 (T1 : Entity_Id; 5243 T2 : Entity_Id; 5244 Fixed_Int : Boolean := False) return Boolean 5245 is 5246 L1 : Node_Id; 5247 H1 : Node_Id; 5248 5249 L2 : Node_Id; 5250 H2 : Node_Id; 5251 5252 begin 5253 if T1 = T2 or else Is_Subtype_Of (T1, T2) then 5254 return True; 5255 5256 -- Never in range if both types are not scalar. Don't know if this can 5257 -- actually happen, but just in case. 5258 5259 elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T2) then 5260 return False; 5261 5262 -- If T1 has infinities but T2 doesn't have infinities, then T1 is 5263 -- definitely not compatible with T2. 5264 5265 elsif Is_Floating_Point_Type (T1) 5266 and then Has_Infinities (T1) 5267 and then Is_Floating_Point_Type (T2) 5268 and then not Has_Infinities (T2) 5269 then 5270 return False; 5271 5272 else 5273 L1 := Type_Low_Bound (T1); 5274 H1 := Type_High_Bound (T1); 5275 5276 L2 := Type_Low_Bound (T2); 5277 H2 := Type_High_Bound (T2); 5278 5279 -- Check bounds to see if comparison possible at compile time 5280 5281 if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE 5282 and then 5283 Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE 5284 then 5285 return True; 5286 end if; 5287 5288 -- If bounds not comparable at compile time, then the bounds of T2 5289 -- must be compile-time-known or we cannot answer the query. 5290 5291 if not Compile_Time_Known_Value (L2) 5292 or else not Compile_Time_Known_Value (H2) 5293 then 5294 return False; 5295 end if; 5296 5297 -- If the bounds of T1 are know at compile time then use these 5298 -- ones, otherwise use the bounds of the base type (which are of 5299 -- course always static). 5300 5301 if not Compile_Time_Known_Value (L1) then 5302 L1 := Type_Low_Bound (Base_Type (T1)); 5303 end if; 5304 5305 if not Compile_Time_Known_Value (H1) then 5306 H1 := Type_High_Bound (Base_Type (T1)); 5307 end if; 5308 5309 -- Fixed point types should be considered as such only if 5310 -- flag Fixed_Int is set to False. 5311 5312 if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2) 5313 or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int) 5314 or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int) 5315 then 5316 return 5317 Expr_Value_R (L2) <= Expr_Value_R (L1) 5318 and then 5319 Expr_Value_R (H2) >= Expr_Value_R (H1); 5320 5321 else 5322 return 5323 Expr_Value (L2) <= Expr_Value (L1) 5324 and then 5325 Expr_Value (H2) >= Expr_Value (H1); 5326 5327 end if; 5328 end if; 5329 5330 -- If any exception occurs, it means that we have some bug in the compiler 5331 -- possibly triggered by a previous error, or by some unforeseen peculiar 5332 -- occurrence. However, this is only an optimization attempt, so there is 5333 -- really no point in crashing the compiler. Instead we just decide, too 5334 -- bad, we can't figure out the answer in this case after all. 5335 5336 exception 5337 when others => 5338 -- With debug flag K we will get an exception unless an error has 5339 -- already occurred (useful for debugging). 5340 5341 if Debug_Flag_K then 5342 Check_Error_Detected; 5343 end if; 5344 5345 return False; 5346 end In_Subrange_Of; 5347 5348 ----------------- 5349 -- Is_In_Range -- 5350 ----------------- 5351 5352 function Is_In_Range 5353 (N : Node_Id; 5354 Typ : Entity_Id; 5355 Assume_Valid : Boolean := False; 5356 Fixed_Int : Boolean := False; 5357 Int_Real : Boolean := False) return Boolean 5358 is 5359 begin 5360 return 5361 Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) = In_Range; 5362 end Is_In_Range; 5363 5364 ------------------- 5365 -- Is_Null_Range -- 5366 ------------------- 5367 5368 function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is 5369 begin 5370 if Compile_Time_Known_Value (Lo) 5371 and then Compile_Time_Known_Value (Hi) 5372 then 5373 declare 5374 Typ : Entity_Id := Etype (Lo); 5375 begin 5376 -- When called from the frontend, as part of the analysis of 5377 -- potentially static expressions, Typ will be the full view of a 5378 -- type with all the info needed to answer this query. When called 5379 -- from the backend, for example to know whether a range of a loop 5380 -- is null, Typ might be a private type and we need to explicitly 5381 -- switch to its corresponding full view to access the same info. 5382 5383 if Is_Incomplete_Or_Private_Type (Typ) 5384 and then Present (Full_View (Typ)) 5385 then 5386 Typ := Full_View (Typ); 5387 end if; 5388 5389 if Is_Discrete_Type (Typ) then 5390 return Expr_Value (Lo) > Expr_Value (Hi); 5391 else pragma Assert (Is_Real_Type (Typ)); 5392 return Expr_Value_R (Lo) > Expr_Value_R (Hi); 5393 end if; 5394 end; 5395 else 5396 return False; 5397 end if; 5398 end Is_Null_Range; 5399 5400 ------------------------- 5401 -- Is_OK_Static_Choice -- 5402 ------------------------- 5403 5404 function Is_OK_Static_Choice (Choice : Node_Id) return Boolean is 5405 begin 5406 -- Check various possibilities for choice 5407 5408 -- Note: for membership tests, we test more cases than are possible 5409 -- (in particular subtype indication), but it doesn't matter because 5410 -- it just won't occur (we have already done a syntax check). 5411 5412 if Nkind (Choice) = N_Others_Choice then 5413 return True; 5414 5415 elsif Nkind (Choice) = N_Range then 5416 return Is_OK_Static_Range (Choice); 5417 5418 elsif Nkind (Choice) = N_Subtype_Indication 5419 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) 5420 then 5421 return Is_OK_Static_Subtype (Etype (Choice)); 5422 5423 else 5424 return Is_OK_Static_Expression (Choice); 5425 end if; 5426 end Is_OK_Static_Choice; 5427 5428 ------------------------------ 5429 -- Is_OK_Static_Choice_List -- 5430 ------------------------------ 5431 5432 function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean is 5433 Choice : Node_Id; 5434 5435 begin 5436 if not Is_Static_Choice_List (Choices) then 5437 return False; 5438 end if; 5439 5440 Choice := First (Choices); 5441 while Present (Choice) loop 5442 if not Is_OK_Static_Choice (Choice) then 5443 Set_Raises_Constraint_Error (Choice); 5444 return False; 5445 end if; 5446 5447 Next (Choice); 5448 end loop; 5449 5450 return True; 5451 end Is_OK_Static_Choice_List; 5452 5453 ----------------------------- 5454 -- Is_OK_Static_Expression -- 5455 ----------------------------- 5456 5457 function Is_OK_Static_Expression (N : Node_Id) return Boolean is 5458 begin 5459 return Is_Static_Expression (N) and then not Raises_Constraint_Error (N); 5460 end Is_OK_Static_Expression; 5461 5462 ------------------------ 5463 -- Is_OK_Static_Range -- 5464 ------------------------ 5465 5466 -- A static range is a range whose bounds are static expressions, or a 5467 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)). 5468 -- We have already converted range attribute references, so we get the 5469 -- "or" part of this rule without needing a special test. 5470 5471 function Is_OK_Static_Range (N : Node_Id) return Boolean is 5472 begin 5473 return Is_OK_Static_Expression (Low_Bound (N)) 5474 and then Is_OK_Static_Expression (High_Bound (N)); 5475 end Is_OK_Static_Range; 5476 5477 -------------------------- 5478 -- Is_OK_Static_Subtype -- 5479 -------------------------- 5480 5481 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where 5482 -- neither bound raises Constraint_Error when evaluated. 5483 5484 function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is 5485 Base_T : constant Entity_Id := Base_Type (Typ); 5486 Anc_Subt : Entity_Id; 5487 5488 begin 5489 -- First a quick check on the non static subtype flag. As described 5490 -- in further detail in Einfo, this flag is not decisive in all cases, 5491 -- but if it is set, then the subtype is definitely non-static. 5492 5493 if Is_Non_Static_Subtype (Typ) then 5494 return False; 5495 end if; 5496 5497 Anc_Subt := Ancestor_Subtype (Typ); 5498 5499 if Anc_Subt = Empty then 5500 Anc_Subt := Base_T; 5501 end if; 5502 5503 if Is_Generic_Type (Root_Type (Base_T)) 5504 or else Is_Generic_Actual_Type (Base_T) 5505 then 5506 return False; 5507 5508 elsif Has_Dynamic_Predicate_Aspect (Typ) then 5509 return False; 5510 5511 -- String types 5512 5513 elsif Is_String_Type (Typ) then 5514 return 5515 Ekind (Typ) = E_String_Literal_Subtype 5516 or else 5517 (Is_OK_Static_Subtype (Component_Type (Typ)) 5518 and then Is_OK_Static_Subtype (Etype (First_Index (Typ)))); 5519 5520 -- Scalar types 5521 5522 elsif Is_Scalar_Type (Typ) then 5523 if Base_T = Typ then 5524 return True; 5525 5526 else 5527 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use 5528 -- Get_Type_{Low,High}_Bound. 5529 5530 return Is_OK_Static_Subtype (Anc_Subt) 5531 and then Is_OK_Static_Expression (Type_Low_Bound (Typ)) 5532 and then Is_OK_Static_Expression (Type_High_Bound (Typ)); 5533 end if; 5534 5535 -- Types other than string and scalar types are never static 5536 5537 else 5538 return False; 5539 end if; 5540 end Is_OK_Static_Subtype; 5541 5542 --------------------- 5543 -- Is_Out_Of_Range -- 5544 --------------------- 5545 5546 function Is_Out_Of_Range 5547 (N : Node_Id; 5548 Typ : Entity_Id; 5549 Assume_Valid : Boolean := False; 5550 Fixed_Int : Boolean := False; 5551 Int_Real : Boolean := False) return Boolean 5552 is 5553 begin 5554 return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) = 5555 Out_Of_Range; 5556 end Is_Out_Of_Range; 5557 5558 ---------------------- 5559 -- Is_Static_Choice -- 5560 ---------------------- 5561 5562 function Is_Static_Choice (Choice : Node_Id) return Boolean is 5563 begin 5564 -- Check various possibilities for choice 5565 5566 -- Note: for membership tests, we test more cases than are possible 5567 -- (in particular subtype indication), but it doesn't matter because 5568 -- it just won't occur (we have already done a syntax check). 5569 5570 if Nkind (Choice) = N_Others_Choice then 5571 return True; 5572 5573 elsif Nkind (Choice) = N_Range then 5574 return Is_Static_Range (Choice); 5575 5576 elsif Nkind (Choice) = N_Subtype_Indication 5577 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) 5578 then 5579 return Is_Static_Subtype (Etype (Choice)); 5580 5581 else 5582 return Is_Static_Expression (Choice); 5583 end if; 5584 end Is_Static_Choice; 5585 5586 --------------------------- 5587 -- Is_Static_Choice_List -- 5588 --------------------------- 5589 5590 function Is_Static_Choice_List (Choices : List_Id) return Boolean is 5591 Choice : Node_Id; 5592 5593 begin 5594 Choice := First (Choices); 5595 while Present (Choice) loop 5596 if not Is_Static_Choice (Choice) then 5597 return False; 5598 end if; 5599 5600 Next (Choice); 5601 end loop; 5602 5603 return True; 5604 end Is_Static_Choice_List; 5605 5606 --------------------- 5607 -- Is_Static_Range -- 5608 --------------------- 5609 5610 -- A static range is a range whose bounds are static expressions, or a 5611 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)). 5612 -- We have already converted range attribute references, so we get the 5613 -- "or" part of this rule without needing a special test. 5614 5615 function Is_Static_Range (N : Node_Id) return Boolean is 5616 begin 5617 return Is_Static_Expression (Low_Bound (N)) 5618 and then 5619 Is_Static_Expression (High_Bound (N)); 5620 end Is_Static_Range; 5621 5622 ----------------------- 5623 -- Is_Static_Subtype -- 5624 ----------------------- 5625 5626 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) 5627 5628 function Is_Static_Subtype (Typ : Entity_Id) return Boolean is 5629 Base_T : constant Entity_Id := Base_Type (Typ); 5630 Anc_Subt : Entity_Id; 5631 5632 begin 5633 -- First a quick check on the non static subtype flag. As described 5634 -- in further detail in Einfo, this flag is not decisive in all cases, 5635 -- but if it is set, then the subtype is definitely non-static. 5636 5637 if Is_Non_Static_Subtype (Typ) then 5638 return False; 5639 end if; 5640 5641 Anc_Subt := Ancestor_Subtype (Typ); 5642 5643 if Anc_Subt = Empty then 5644 Anc_Subt := Base_T; 5645 end if; 5646 5647 if Is_Generic_Type (Root_Type (Base_T)) 5648 or else Is_Generic_Actual_Type (Base_T) 5649 then 5650 return False; 5651 5652 -- If there is a dynamic predicate for the type (declared or inherited) 5653 -- the expression is not static. 5654 5655 elsif Has_Dynamic_Predicate_Aspect (Typ) 5656 or else (Is_Derived_Type (Typ) 5657 and then Has_Aspect (Typ, Aspect_Dynamic_Predicate)) 5658 then 5659 return False; 5660 5661 -- String types 5662 5663 elsif Is_String_Type (Typ) then 5664 return 5665 Ekind (Typ) = E_String_Literal_Subtype 5666 or else (Is_Static_Subtype (Component_Type (Typ)) 5667 and then Is_Static_Subtype (Etype (First_Index (Typ)))); 5668 5669 -- Scalar types 5670 5671 elsif Is_Scalar_Type (Typ) then 5672 if Base_T = Typ then 5673 return True; 5674 5675 else 5676 return Is_Static_Subtype (Anc_Subt) 5677 and then Is_Static_Expression (Type_Low_Bound (Typ)) 5678 and then Is_Static_Expression (Type_High_Bound (Typ)); 5679 end if; 5680 5681 -- Types other than string and scalar types are never static 5682 5683 else 5684 return False; 5685 end if; 5686 end Is_Static_Subtype; 5687 5688 ------------------------------- 5689 -- Is_Statically_Unevaluated -- 5690 ------------------------------- 5691 5692 function Is_Statically_Unevaluated (Expr : Node_Id) return Boolean is 5693 function Check_Case_Expr_Alternative 5694 (CEA : Node_Id) return Match_Result; 5695 -- We have a message emanating from the Expression of a case expression 5696 -- alternative. We examine this alternative, as follows: 5697 -- 5698 -- If the selecting expression of the parent case is non-static, or 5699 -- if any of the discrete choices of the given case alternative are 5700 -- non-static or raise Constraint_Error, return Non_Static. 5701 -- 5702 -- Otherwise check if the selecting expression matches any of the given 5703 -- discrete choices. If so, the alternative is executed and we return 5704 -- Match, otherwise, the alternative can never be executed, and so we 5705 -- return No_Match. 5706 5707 --------------------------------- 5708 -- Check_Case_Expr_Alternative -- 5709 --------------------------------- 5710 5711 function Check_Case_Expr_Alternative 5712 (CEA : Node_Id) return Match_Result 5713 is 5714 Case_Exp : constant Node_Id := Parent (CEA); 5715 Choice : Node_Id; 5716 Prev_CEA : Node_Id; 5717 5718 begin 5719 pragma Assert (Nkind (Case_Exp) = N_Case_Expression); 5720 5721 -- Check that selecting expression is static 5722 5723 if not Is_OK_Static_Expression (Expression (Case_Exp)) then 5724 return Non_Static; 5725 end if; 5726 5727 if not Is_OK_Static_Choice_List (Discrete_Choices (CEA)) then 5728 return Non_Static; 5729 end if; 5730 5731 -- All choices are now known to be static. Now see if alternative 5732 -- matches one of the choices. 5733 5734 Choice := First (Discrete_Choices (CEA)); 5735 while Present (Choice) loop 5736 5737 -- Check various possibilities for choice, returning Match if we 5738 -- find the selecting value matches any of the choices. Note that 5739 -- we know we are the last choice, so we don't have to keep going. 5740 5741 if Nkind (Choice) = N_Others_Choice then 5742 5743 -- Others choice is a bit annoying, it matches if none of the 5744 -- previous alternatives matches (note that we know we are the 5745 -- last alternative in this case, so we can just go backwards 5746 -- from us to see if any previous one matches). 5747 5748 Prev_CEA := Prev (CEA); 5749 while Present (Prev_CEA) loop 5750 if Check_Case_Expr_Alternative (Prev_CEA) = Match then 5751 return No_Match; 5752 end if; 5753 5754 Prev (Prev_CEA); 5755 end loop; 5756 5757 return Match; 5758 5759 -- Else we have a normal static choice 5760 5761 elsif Choice_Matches (Expression (Case_Exp), Choice) = Match then 5762 return Match; 5763 end if; 5764 5765 -- If we fall through, it means that the discrete choice did not 5766 -- match the selecting expression, so continue. 5767 5768 Next (Choice); 5769 end loop; 5770 5771 -- If we get through that loop then all choices were static, and none 5772 -- of them matched the selecting expression. So return No_Match. 5773 5774 return No_Match; 5775 end Check_Case_Expr_Alternative; 5776 5777 -- Local variables 5778 5779 P : Node_Id; 5780 OldP : Node_Id; 5781 Choice : Node_Id; 5782 5783 -- Start of processing for Is_Statically_Unevaluated 5784 5785 begin 5786 -- The (32.x) references here are from RM section 4.9 5787 5788 -- (32.1) An expression is statically unevaluated if it is part of ... 5789 5790 -- This means we have to climb the tree looking for one of the cases 5791 5792 P := Expr; 5793 loop 5794 OldP := P; 5795 P := Parent (P); 5796 5797 -- (32.2) The right operand of a static short-circuit control form 5798 -- whose value is determined by its left operand. 5799 5800 -- AND THEN with False as left operand 5801 5802 if Nkind (P) = N_And_Then 5803 and then Compile_Time_Known_Value (Left_Opnd (P)) 5804 and then Is_False (Expr_Value (Left_Opnd (P))) 5805 then 5806 return True; 5807 5808 -- OR ELSE with True as left operand 5809 5810 elsif Nkind (P) = N_Or_Else 5811 and then Compile_Time_Known_Value (Left_Opnd (P)) 5812 and then Is_True (Expr_Value (Left_Opnd (P))) 5813 then 5814 return True; 5815 5816 -- (32.3) A dependent_expression of an if_expression whose associated 5817 -- condition is static and equals False. 5818 5819 elsif Nkind (P) = N_If_Expression then 5820 declare 5821 Cond : constant Node_Id := First (Expressions (P)); 5822 Texp : constant Node_Id := Next (Cond); 5823 Fexp : constant Node_Id := Next (Texp); 5824 5825 begin 5826 if Compile_Time_Known_Value (Cond) then 5827 5828 -- Condition is True and we are in the right operand 5829 5830 if Is_True (Expr_Value (Cond)) and then OldP = Fexp then 5831 return True; 5832 5833 -- Condition is False and we are in the left operand 5834 5835 elsif Is_False (Expr_Value (Cond)) and then OldP = Texp then 5836 return True; 5837 end if; 5838 end if; 5839 end; 5840 5841 -- (32.4) A condition or dependent_expression of an if_expression 5842 -- where the condition corresponding to at least one preceding 5843 -- dependent_expression of the if_expression is static and equals 5844 -- True. 5845 5846 -- This refers to cases like 5847 5848 -- (if True then 1 elsif 1/0=2 then 2 else 3) 5849 5850 -- But we expand elsif's out anyway, so the above looks like: 5851 5852 -- (if True then 1 else (if 1/0=2 then 2 else 3)) 5853 5854 -- So for us this is caught by the above check for the 32.3 case. 5855 5856 -- (32.5) A dependent_expression of a case_expression whose 5857 -- selecting_expression is static and whose value is not covered 5858 -- by the corresponding discrete_choice_list. 5859 5860 elsif Nkind (P) = N_Case_Expression_Alternative then 5861 5862 -- First, we have to be in the expression to suppress messages. 5863 -- If we are within one of the choices, we want the message. 5864 5865 if OldP = Expression (P) then 5866 5867 -- Statically unevaluated if alternative does not match 5868 5869 if Check_Case_Expr_Alternative (P) = No_Match then 5870 return True; 5871 end if; 5872 end if; 5873 5874 -- (32.6) A choice_expression (or a simple_expression of a range 5875 -- that occurs as a membership_choice of a membership_choice_list) 5876 -- of a static membership test that is preceded in the enclosing 5877 -- membership_choice_list by another item whose individual 5878 -- membership test (see (RM 4.5.2)) statically yields True. 5879 5880 elsif Nkind (P) in N_Membership_Test then 5881 5882 -- Only possibly unevaluated if simple expression is static 5883 5884 if not Is_OK_Static_Expression (Left_Opnd (P)) then 5885 null; 5886 5887 -- All members of the choice list must be static 5888 5889 elsif (Present (Right_Opnd (P)) 5890 and then not Is_OK_Static_Choice (Right_Opnd (P))) 5891 or else (Present (Alternatives (P)) 5892 and then 5893 not Is_OK_Static_Choice_List (Alternatives (P))) 5894 then 5895 null; 5896 5897 -- If expression is the one and only alternative, then it is 5898 -- definitely not statically unevaluated, so we only have to 5899 -- test the case where there are alternatives present. 5900 5901 elsif Present (Alternatives (P)) then 5902 5903 -- Look for previous matching Choice 5904 5905 Choice := First (Alternatives (P)); 5906 while Present (Choice) loop 5907 5908 -- If we reached us and no previous choices matched, this 5909 -- is not the case where we are statically unevaluated. 5910 5911 exit when OldP = Choice; 5912 5913 -- If a previous choice matches, then that is the case where 5914 -- we know our choice is statically unevaluated. 5915 5916 if Choice_Matches (Left_Opnd (P), Choice) = Match then 5917 return True; 5918 end if; 5919 5920 Next (Choice); 5921 end loop; 5922 5923 -- If we fall through the loop, we were not one of the choices, 5924 -- we must have been the expression, so that is not covered by 5925 -- this rule, and we keep going. 5926 5927 null; 5928 end if; 5929 end if; 5930 5931 -- OK, not statically unevaluated at this level, see if we should 5932 -- keep climbing to look for a higher level reason. 5933 5934 -- Special case for component association in aggregates, where 5935 -- we want to keep climbing up to the parent aggregate. 5936 5937 if Nkind (P) = N_Component_Association 5938 and then Nkind (Parent (P)) = N_Aggregate 5939 then 5940 null; 5941 5942 -- All done if not still within subexpression 5943 5944 else 5945 exit when Nkind (P) not in N_Subexpr; 5946 end if; 5947 end loop; 5948 5949 -- If we fall through the loop, not one of the cases covered! 5950 5951 return False; 5952 end Is_Statically_Unevaluated; 5953 5954 -------------------- 5955 -- Not_Null_Range -- 5956 -------------------- 5957 5958 function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is 5959 begin 5960 if Compile_Time_Known_Value (Lo) 5961 and then Compile_Time_Known_Value (Hi) 5962 then 5963 declare 5964 Typ : Entity_Id := Etype (Lo); 5965 begin 5966 -- When called from the frontend, as part of the analysis of 5967 -- potentially static expressions, Typ will be the full view of a 5968 -- type with all the info needed to answer this query. When called 5969 -- from the backend, for example to know whether a range of a loop 5970 -- is null, Typ might be a private type and we need to explicitly 5971 -- switch to its corresponding full view to access the same info. 5972 5973 if Is_Incomplete_Or_Private_Type (Typ) 5974 and then Present (Full_View (Typ)) 5975 then 5976 Typ := Full_View (Typ); 5977 end if; 5978 5979 if Is_Discrete_Type (Typ) then 5980 return Expr_Value (Lo) <= Expr_Value (Hi); 5981 else pragma Assert (Is_Real_Type (Typ)); 5982 return Expr_Value_R (Lo) <= Expr_Value_R (Hi); 5983 end if; 5984 end; 5985 else 5986 return False; 5987 end if; 5988 5989 end Not_Null_Range; 5990 5991 ------------- 5992 -- OK_Bits -- 5993 ------------- 5994 5995 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is 5996 begin 5997 -- We allow a maximum of 500,000 bits which seems a reasonable limit 5998 5999 if Bits < 500_000 then 6000 return True; 6001 6002 -- Error if this maximum is exceeded 6003 6004 else 6005 Error_Msg_N ("static value too large, capacity exceeded", N); 6006 return False; 6007 end if; 6008 end OK_Bits; 6009 6010 ------------------ 6011 -- Out_Of_Range -- 6012 ------------------ 6013 6014 procedure Out_Of_Range (N : Node_Id) is 6015 begin 6016 -- If we have the static expression case, then this is an illegality 6017 -- in Ada 95 mode, except that in an instance, we never generate an 6018 -- error (if the error is legitimate, it was already diagnosed in the 6019 -- template). 6020 6021 if Is_Static_Expression (N) 6022 and then not In_Instance 6023 and then not In_Inlined_Body 6024 and then Ada_Version >= Ada_95 6025 then 6026 -- No message if we are statically unevaluated 6027 6028 if Is_Statically_Unevaluated (N) then 6029 null; 6030 6031 -- The expression to compute the length of a packed array is attached 6032 -- to the array type itself, and deserves a separate message. 6033 6034 elsif Nkind (Parent (N)) = N_Defining_Identifier 6035 and then Is_Array_Type (Parent (N)) 6036 and then Present (Packed_Array_Impl_Type (Parent (N))) 6037 and then Present (First_Rep_Item (Parent (N))) 6038 then 6039 Error_Msg_N 6040 ("length of packed array must not exceed Integer''Last", 6041 First_Rep_Item (Parent (N))); 6042 Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1)); 6043 6044 -- All cases except the special array case. 6045 -- No message if we are dealing with System.Priority values in 6046 -- CodePeer mode where the target runtime may have more priorities. 6047 6048 elsif not CodePeer_Mode or else Etype (N) /= RTE (RE_Priority) then 6049 -- Determine if the out-of-range violation constitutes a warning 6050 -- or an error based on context, according to RM 4.9 (34/3). 6051 6052 if Nkind (Original_Node (N)) = N_Type_Conversion 6053 and then not Comes_From_Source (Original_Node (N)) 6054 then 6055 Apply_Compile_Time_Constraint_Error 6056 (N, "value not in range of}??", CE_Range_Check_Failed); 6057 else 6058 Apply_Compile_Time_Constraint_Error 6059 (N, "value not in range of}", CE_Range_Check_Failed); 6060 end if; 6061 end if; 6062 6063 -- Here we generate a warning for the Ada 83 case, or when we are in an 6064 -- instance, or when we have a non-static expression case. 6065 6066 else 6067 Apply_Compile_Time_Constraint_Error 6068 (N, "value not in range of}??", CE_Range_Check_Failed); 6069 end if; 6070 end Out_Of_Range; 6071 6072 --------------------------- 6073 -- Predicates_Compatible -- 6074 --------------------------- 6075 6076 function Predicates_Compatible (T1, T2 : Entity_Id) return Boolean is 6077 6078 function T2_Rep_Item_Applies_To_T1 (Nam : Name_Id) return Boolean; 6079 -- Return True if the rep item for Nam is either absent on T2 or also 6080 -- applies to T1. 6081 6082 ------------------------------- 6083 -- T2_Rep_Item_Applies_To_T1 -- 6084 ------------------------------- 6085 6086 function T2_Rep_Item_Applies_To_T1 (Nam : Name_Id) return Boolean is 6087 Rep_Item : constant Node_Id := Get_Rep_Item (T2, Nam); 6088 6089 begin 6090 return No (Rep_Item) or else Get_Rep_Item (T1, Nam) = Rep_Item; 6091 end T2_Rep_Item_Applies_To_T1; 6092 6093 -- Start of processing for Predicates_Compatible 6094 6095 begin 6096 if Ada_Version < Ada_2012 then 6097 return True; 6098 6099 -- If T2 has no predicates, there is no compatibility issue 6100 6101 elsif not Has_Predicates (T2) then 6102 return True; 6103 6104 -- T2 has predicates, if T1 has none then we defer to the static check 6105 6106 elsif not Has_Predicates (T1) then 6107 null; 6108 6109 -- Both T2 and T1 have predicates, check that all predicates that apply 6110 -- to T2 apply also to T1 (RM 4.9.1(9/3)). 6111 6112 elsif T2_Rep_Item_Applies_To_T1 (Name_Static_Predicate) 6113 and then T2_Rep_Item_Applies_To_T1 (Name_Dynamic_Predicate) 6114 and then T2_Rep_Item_Applies_To_T1 (Name_Predicate) 6115 then 6116 return True; 6117 end if; 6118 6119 -- Implement the static check prescribed by RM 4.9.1(10/3) 6120 6121 if Is_Static_Subtype (T1) and then Is_Static_Subtype (T2) then 6122 -- We just need to query Interval_Lists for discrete types 6123 6124 if Is_Discrete_Type (T1) and then Is_Discrete_Type (T2) then 6125 declare 6126 Interval_List1 : constant Interval_Lists.Discrete_Interval_List 6127 := Interval_Lists.Type_Intervals (T1); 6128 Interval_List2 : constant Interval_Lists.Discrete_Interval_List 6129 := Interval_Lists.Type_Intervals (T2); 6130 begin 6131 return Interval_Lists.Is_Subset (Interval_List1, Interval_List2) 6132 and then not (Has_Predicates (T1) 6133 and then not Predicate_Checks_Suppressed (T2) 6134 and then Predicate_Checks_Suppressed (T1)); 6135 end; 6136 6137 else 6138 -- TBD: Implement Interval_Lists for real types 6139 6140 return False; 6141 end if; 6142 6143 -- If either subtype is not static, the predicates are not compatible 6144 6145 else 6146 return False; 6147 end if; 6148 end Predicates_Compatible; 6149 6150 ---------------------- 6151 -- Predicates_Match -- 6152 ---------------------- 6153 6154 function Predicates_Match (T1, T2 : Entity_Id) return Boolean is 6155 6156 function Have_Same_Rep_Item (Nam : Name_Id) return Boolean; 6157 -- Return True if T1 and T2 have the same rep item for Nam 6158 6159 ------------------------ 6160 -- Have_Same_Rep_Item -- 6161 ------------------------ 6162 6163 function Have_Same_Rep_Item (Nam : Name_Id) return Boolean is 6164 begin 6165 return Get_Rep_Item (T1, Nam) = Get_Rep_Item (T2, Nam); 6166 end Have_Same_Rep_Item; 6167 6168 -- Start of processing for Predicates_Match 6169 6170 begin 6171 if Ada_Version < Ada_2012 then 6172 return True; 6173 6174 -- If T2 has no predicates, match if and only if T1 has none 6175 6176 elsif not Has_Predicates (T2) then 6177 return not Has_Predicates (T1); 6178 6179 -- T2 has predicates, no match if T1 has none 6180 6181 elsif not Has_Predicates (T1) then 6182 return False; 6183 6184 -- Both T2 and T1 have predicates, check that they all come 6185 -- from the same declarations. 6186 6187 else 6188 return Have_Same_Rep_Item (Name_Static_Predicate) 6189 and then Have_Same_Rep_Item (Name_Dynamic_Predicate) 6190 and then Have_Same_Rep_Item (Name_Predicate); 6191 end if; 6192 end Predicates_Match; 6193 6194 --------------------------------------------- 6195 -- Real_Or_String_Static_Predicate_Matches -- 6196 --------------------------------------------- 6197 6198 function Real_Or_String_Static_Predicate_Matches 6199 (Val : Node_Id; 6200 Typ : Entity_Id) return Boolean 6201 is 6202 Expr : constant Node_Id := Static_Real_Or_String_Predicate (Typ); 6203 -- The predicate expression from the type 6204 6205 Pfun : constant Entity_Id := Predicate_Function (Typ); 6206 -- The entity for the predicate function 6207 6208 Ent_Name : constant Name_Id := Chars (First_Formal (Pfun)); 6209 -- The name of the formal of the predicate function. Occurrences of the 6210 -- type name in Expr have been rewritten as references to this formal, 6211 -- and it has a unique name, so we can identify references by this name. 6212 6213 Copy : Node_Id; 6214 -- Copy of the predicate function tree 6215 6216 function Process (N : Node_Id) return Traverse_Result; 6217 -- Function used to process nodes during the traversal in which we will 6218 -- find occurrences of the entity name, and replace such occurrences 6219 -- by a real literal with the value to be tested. 6220 6221 procedure Traverse is new Traverse_Proc (Process); 6222 -- The actual traversal procedure 6223 6224 ------------- 6225 -- Process -- 6226 ------------- 6227 6228 function Process (N : Node_Id) return Traverse_Result is 6229 begin 6230 if Nkind (N) = N_Identifier and then Chars (N) = Ent_Name then 6231 declare 6232 Nod : constant Node_Id := New_Copy (Val); 6233 begin 6234 Set_Sloc (Nod, Sloc (N)); 6235 Rewrite (N, Nod); 6236 return Skip; 6237 end; 6238 6239 -- The predicate function may contain string-comparison operations 6240 -- that have been converted into calls to run-time array-comparison 6241 -- routines. To evaluate the predicate statically, we recover the 6242 -- original comparison operation and replace the occurrence of the 6243 -- formal by the static string value. The actuals of the generated 6244 -- call are of the form X'Address. 6245 6246 elsif Nkind (N) in N_Op_Compare 6247 and then Nkind (Left_Opnd (N)) = N_Function_Call 6248 then 6249 declare 6250 C : constant Node_Id := Left_Opnd (N); 6251 F : constant Node_Id := First (Parameter_Associations (C)); 6252 L : constant Node_Id := Prefix (F); 6253 R : constant Node_Id := Prefix (Next (F)); 6254 6255 begin 6256 -- If an operand is an entity name, it is the formal of the 6257 -- predicate function, so replace it with the string value. 6258 -- It may be either operand in the call. The other operand 6259 -- is a static string from the original predicate. 6260 6261 if Is_Entity_Name (L) then 6262 Rewrite (Left_Opnd (N), New_Copy (Val)); 6263 Rewrite (Right_Opnd (N), New_Copy (R)); 6264 6265 else 6266 Rewrite (Left_Opnd (N), New_Copy (L)); 6267 Rewrite (Right_Opnd (N), New_Copy (Val)); 6268 end if; 6269 6270 return Skip; 6271 end; 6272 6273 else 6274 return OK; 6275 end if; 6276 end Process; 6277 6278 -- Start of processing for Real_Or_String_Static_Predicate_Matches 6279 6280 begin 6281 -- First deal with special case of inherited predicate, where the 6282 -- predicate expression looks like: 6283 6284 -- xxPredicate (typ (Ent)) and then Expr 6285 6286 -- where Expr is the predicate expression for this level, and the 6287 -- left operand is the call to evaluate the inherited predicate. 6288 6289 if Nkind (Expr) = N_And_Then 6290 and then Nkind (Left_Opnd (Expr)) = N_Function_Call 6291 and then Is_Predicate_Function (Entity (Name (Left_Opnd (Expr)))) 6292 then 6293 -- OK we have the inherited case, so make a call to evaluate the 6294 -- inherited predicate. If that fails, so do we! 6295 6296 if not 6297 Real_Or_String_Static_Predicate_Matches 6298 (Val => Val, 6299 Typ => Etype (First_Formal (Entity (Name (Left_Opnd (Expr)))))) 6300 then 6301 return False; 6302 end if; 6303 6304 -- Use the right operand for the continued processing 6305 6306 Copy := Copy_Separate_Tree (Right_Opnd (Expr)); 6307 6308 -- Case where call to predicate function appears on its own (this means 6309 -- that the predicate at this level is just inherited from the parent). 6310 6311 elsif Nkind (Expr) = N_Function_Call then 6312 declare 6313 Typ : constant Entity_Id := 6314 Etype (First_Formal (Entity (Name (Expr)))); 6315 6316 begin 6317 -- If the inherited predicate is dynamic, just ignore it. We can't 6318 -- go trying to evaluate a dynamic predicate as a static one! 6319 6320 if Has_Dynamic_Predicate_Aspect (Typ) then 6321 return True; 6322 6323 -- Otherwise inherited predicate is static, check for match 6324 6325 else 6326 return Real_Or_String_Static_Predicate_Matches (Val, Typ); 6327 end if; 6328 end; 6329 6330 -- If not just an inherited predicate, copy whole expression 6331 6332 else 6333 Copy := Copy_Separate_Tree (Expr); 6334 end if; 6335 6336 -- Now we replace occurrences of the entity by the value 6337 6338 Traverse (Copy); 6339 6340 -- And analyze the resulting static expression to see if it is True 6341 6342 Analyze_And_Resolve (Copy, Standard_Boolean); 6343 return Is_True (Expr_Value (Copy)); 6344 end Real_Or_String_Static_Predicate_Matches; 6345 6346 ------------------------- 6347 -- Rewrite_In_Raise_CE -- 6348 ------------------------- 6349 6350 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is 6351 Stat : constant Boolean := Is_Static_Expression (N); 6352 Typ : constant Entity_Id := Etype (N); 6353 6354 begin 6355 -- If we want to raise CE in the condition of a N_Raise_CE node, we 6356 -- can just clear the condition if the reason is appropriate. We do 6357 -- not do this operation if the parent has a reason other than range 6358 -- check failed, because otherwise we would change the reason. 6359 6360 if Present (Parent (N)) 6361 and then Nkind (Parent (N)) = N_Raise_Constraint_Error 6362 and then Reason (Parent (N)) = 6363 UI_From_Int (RT_Exception_Code'Pos (CE_Range_Check_Failed)) 6364 then 6365 Set_Condition (Parent (N), Empty); 6366 6367 -- Else build an explicit N_Raise_CE 6368 6369 else 6370 if Nkind (Exp) = N_Raise_Constraint_Error then 6371 Rewrite (N, 6372 Make_Raise_Constraint_Error (Sloc (Exp), 6373 Reason => Reason (Exp))); 6374 else 6375 Rewrite (N, 6376 Make_Raise_Constraint_Error (Sloc (Exp), 6377 Reason => CE_Range_Check_Failed)); 6378 end if; 6379 6380 Set_Raises_Constraint_Error (N); 6381 Set_Etype (N, Typ); 6382 end if; 6383 6384 -- Set proper flags in result 6385 6386 Set_Raises_Constraint_Error (N, True); 6387 Set_Is_Static_Expression (N, Stat); 6388 end Rewrite_In_Raise_CE; 6389 6390 ------------------------------------------------ 6391 -- Set_Checking_Potentially_Static_Expression -- 6392 ------------------------------------------------ 6393 6394 procedure Set_Checking_Potentially_Static_Expression (Value : Boolean) is 6395 begin 6396 -- Verify that we're not currently checking for a potentially static 6397 -- expression unless we're disabling such checking. 6398 6399 pragma Assert 6400 (not Checking_For_Potentially_Static_Expression or else not Value); 6401 6402 Checking_For_Potentially_Static_Expression := Value; 6403 end Set_Checking_Potentially_Static_Expression; 6404 6405 --------------------- 6406 -- String_Type_Len -- 6407 --------------------- 6408 6409 function String_Type_Len (Stype : Entity_Id) return Uint is 6410 NT : constant Entity_Id := Etype (First_Index (Stype)); 6411 T : Entity_Id; 6412 6413 begin 6414 if Is_OK_Static_Subtype (NT) then 6415 T := NT; 6416 else 6417 T := Base_Type (NT); 6418 end if; 6419 6420 return Expr_Value (Type_High_Bound (T)) - 6421 Expr_Value (Type_Low_Bound (T)) + 1; 6422 end String_Type_Len; 6423 6424 ------------------------------------ 6425 -- Subtypes_Statically_Compatible -- 6426 ------------------------------------ 6427 6428 function Subtypes_Statically_Compatible 6429 (T1 : Entity_Id; 6430 T2 : Entity_Id; 6431 Formal_Derived_Matching : Boolean := False) return Boolean 6432 is 6433 begin 6434 -- A type is always statically compatible with itself 6435 6436 if T1 = T2 then 6437 return True; 6438 6439 -- Not compatible if predicates are not compatible 6440 6441 elsif not Predicates_Compatible (T1, T2) then 6442 return False; 6443 6444 -- Scalar types 6445 6446 elsif Is_Scalar_Type (T1) then 6447 6448 -- Definitely compatible if we match 6449 6450 if Subtypes_Statically_Match (T1, T2) then 6451 return True; 6452 6453 -- A scalar subtype S1 is compatible with S2 if their bounds 6454 -- are static and compatible, even if S1 has dynamic predicates 6455 -- and is thus non-static. Predicate compatibility has been 6456 -- checked above. 6457 6458 elsif not Is_Static_Range (Scalar_Range (T1)) 6459 or else not Is_Static_Range (Scalar_Range (T2)) 6460 then 6461 return False; 6462 6463 -- Base types must match, but we don't check that (should we???) but 6464 -- we do at least check that both types are real, or both types are 6465 -- not real. 6466 6467 elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then 6468 return False; 6469 6470 -- Here we check the bounds 6471 6472 else 6473 declare 6474 LB1 : constant Node_Id := Type_Low_Bound (T1); 6475 HB1 : constant Node_Id := Type_High_Bound (T1); 6476 LB2 : constant Node_Id := Type_Low_Bound (T2); 6477 HB2 : constant Node_Id := Type_High_Bound (T2); 6478 6479 begin 6480 if Is_Real_Type (T1) then 6481 return 6482 Expr_Value_R (LB1) > Expr_Value_R (HB1) 6483 or else 6484 (Expr_Value_R (LB2) <= Expr_Value_R (LB1) 6485 and then Expr_Value_R (HB1) <= Expr_Value_R (HB2)); 6486 6487 else 6488 return 6489 Expr_Value (LB1) > Expr_Value (HB1) 6490 or else 6491 (Expr_Value (LB2) <= Expr_Value (LB1) 6492 and then Expr_Value (HB1) <= Expr_Value (HB2)); 6493 end if; 6494 end; 6495 end if; 6496 6497 -- Access types 6498 6499 elsif Is_Access_Type (T1) then 6500 return 6501 (not Is_Constrained (T2) 6502 or else Subtypes_Statically_Match 6503 (Designated_Type (T1), Designated_Type (T2))) 6504 and then not (Can_Never_Be_Null (T2) 6505 and then not Can_Never_Be_Null (T1)); 6506 6507 -- Private types without discriminants can be handled specially. 6508 -- Predicate matching has been checked above. 6509 6510 elsif Is_Private_Type (T1) 6511 and then not Has_Discriminants (T1) 6512 then 6513 return not Has_Discriminants (T2); 6514 6515 -- All other cases 6516 6517 else 6518 return 6519 (Is_Composite_Type (T1) and then not Is_Constrained (T2)) 6520 or else Subtypes_Statically_Match 6521 (T1, T2, Formal_Derived_Matching); 6522 end if; 6523 end Subtypes_Statically_Compatible; 6524 6525 ------------------------------- 6526 -- Subtypes_Statically_Match -- 6527 ------------------------------- 6528 6529 -- Subtypes statically match if they have statically matching constraints 6530 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if 6531 -- they are the same identical constraint, or if they are static and the 6532 -- values match (RM 4.9.1(1)). 6533 6534 -- In addition, in GNAT, the object size (Esize) values of the types must 6535 -- match if they are set (unless checking an actual for a formal derived 6536 -- type). The use of 'Object_Size can cause this to be false even if the 6537 -- types would otherwise match in the Ada 95 RM sense, but this deviation 6538 -- is adopted by AI12-059 which introduces Object_Size in Ada 2020. 6539 6540 function Subtypes_Statically_Match 6541 (T1 : Entity_Id; 6542 T2 : Entity_Id; 6543 Formal_Derived_Matching : Boolean := False) return Boolean 6544 is 6545 begin 6546 -- A type always statically matches itself 6547 6548 if T1 = T2 then 6549 return True; 6550 6551 -- No match if sizes different (from use of 'Object_Size). This test 6552 -- is excluded if Formal_Derived_Matching is True, as the base types 6553 -- can be different in that case and typically have different sizes. 6554 6555 elsif not Formal_Derived_Matching 6556 and then Known_Static_Esize (T1) 6557 and then Known_Static_Esize (T2) 6558 and then Esize (T1) /= Esize (T2) 6559 then 6560 return False; 6561 6562 -- No match if predicates do not match 6563 6564 elsif not Predicates_Match (T1, T2) then 6565 return False; 6566 6567 -- Scalar types 6568 6569 elsif Is_Scalar_Type (T1) then 6570 6571 -- Base types must be the same 6572 6573 if Base_Type (T1) /= Base_Type (T2) then 6574 return False; 6575 end if; 6576 6577 -- A constrained numeric subtype never matches an unconstrained 6578 -- subtype, i.e. both types must be constrained or unconstrained. 6579 6580 -- To understand the requirement for this test, see RM 4.9.1(1). 6581 -- As is made clear in RM 3.5.4(11), type Integer, for example is 6582 -- a constrained subtype with constraint bounds matching the bounds 6583 -- of its corresponding unconstrained base type. In this situation, 6584 -- Integer and Integer'Base do not statically match, even though 6585 -- they have the same bounds. 6586 6587 -- We only apply this test to types in Standard and types that appear 6588 -- in user programs. That way, we do not have to be too careful about 6589 -- setting Is_Constrained right for Itypes. 6590 6591 if Is_Numeric_Type (T1) 6592 and then (Is_Constrained (T1) /= Is_Constrained (T2)) 6593 and then (Scope (T1) = Standard_Standard 6594 or else Comes_From_Source (T1)) 6595 and then (Scope (T2) = Standard_Standard 6596 or else Comes_From_Source (T2)) 6597 then 6598 return False; 6599 6600 -- A generic scalar type does not statically match its base type 6601 -- (AI-311). In this case we make sure that the formals, which are 6602 -- first subtypes of their bases, are constrained. 6603 6604 elsif Is_Generic_Type (T1) 6605 and then Is_Generic_Type (T2) 6606 and then (Is_Constrained (T1) /= Is_Constrained (T2)) 6607 then 6608 return False; 6609 end if; 6610 6611 -- If there was an error in either range, then just assume the types 6612 -- statically match to avoid further junk errors. 6613 6614 if No (Scalar_Range (T1)) or else No (Scalar_Range (T2)) 6615 or else Error_Posted (Scalar_Range (T1)) 6616 or else Error_Posted (Scalar_Range (T2)) 6617 then 6618 return True; 6619 end if; 6620 6621 -- Otherwise both types have bounds that can be compared 6622 6623 declare 6624 LB1 : constant Node_Id := Type_Low_Bound (T1); 6625 HB1 : constant Node_Id := Type_High_Bound (T1); 6626 LB2 : constant Node_Id := Type_Low_Bound (T2); 6627 HB2 : constant Node_Id := Type_High_Bound (T2); 6628 6629 begin 6630 -- If the bounds are the same tree node, then match (common case) 6631 6632 if LB1 = LB2 and then HB1 = HB2 then 6633 return True; 6634 6635 -- Otherwise bounds must be static and identical value 6636 6637 else 6638 if not Is_OK_Static_Subtype (T1) 6639 or else 6640 not Is_OK_Static_Subtype (T2) 6641 then 6642 return False; 6643 6644 elsif Is_Real_Type (T1) then 6645 return 6646 Expr_Value_R (LB1) = Expr_Value_R (LB2) 6647 and then 6648 Expr_Value_R (HB1) = Expr_Value_R (HB2); 6649 6650 else 6651 return 6652 Expr_Value (LB1) = Expr_Value (LB2) 6653 and then 6654 Expr_Value (HB1) = Expr_Value (HB2); 6655 end if; 6656 end if; 6657 end; 6658 6659 -- Type with discriminants 6660 6661 elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then 6662 6663 -- Handle derivations of private subtypes. For example S1 statically 6664 -- matches the full view of T1 in the following example: 6665 6666 -- type T1(<>) is new Root with private; 6667 -- subtype S1 is new T1; 6668 -- overriding proc P1 (P : S1); 6669 -- private 6670 -- type T1 (D : Disc) is new Root with ... 6671 6672 if Ekind (T2) = E_Record_Subtype_With_Private 6673 and then not Has_Discriminants (T2) 6674 and then Partial_View_Has_Unknown_Discr (T1) 6675 and then Etype (T2) = T1 6676 then 6677 return True; 6678 6679 elsif Ekind (T1) = E_Record_Subtype_With_Private 6680 and then not Has_Discriminants (T1) 6681 and then Partial_View_Has_Unknown_Discr (T2) 6682 and then Etype (T1) = T2 6683 then 6684 return True; 6685 6686 -- Because of view exchanges in multiple instantiations, conformance 6687 -- checking might try to match a partial view of a type with no 6688 -- discriminants with a full view that has defaulted discriminants. 6689 -- In such a case, use the discriminant constraint of the full view, 6690 -- which must exist because we know that the two subtypes have the 6691 -- same base type. 6692 6693 elsif Has_Discriminants (T1) /= Has_Discriminants (T2) then 6694 if In_Instance then 6695 if Is_Private_Type (T2) 6696 and then Present (Full_View (T2)) 6697 and then Has_Discriminants (Full_View (T2)) 6698 then 6699 return Subtypes_Statically_Match (T1, Full_View (T2)); 6700 6701 elsif Is_Private_Type (T1) 6702 and then Present (Full_View (T1)) 6703 and then Has_Discriminants (Full_View (T1)) 6704 then 6705 return Subtypes_Statically_Match (Full_View (T1), T2); 6706 6707 else 6708 return False; 6709 end if; 6710 else 6711 return False; 6712 end if; 6713 end if; 6714 6715 declare 6716 6717 function Original_Discriminant_Constraint 6718 (Typ : Entity_Id) return Elist_Id; 6719 -- Returns Typ's discriminant constraint, or if the constraint 6720 -- is inherited from an ancestor type, then climbs the parent 6721 -- types to locate and return the constraint farthest up the 6722 -- parent chain that Typ's constraint is ultimately inherited 6723 -- from (stopping before a parent that doesn't impose a constraint 6724 -- or a parent that has new discriminants). This ensures a proper 6725 -- result from the equality comparison of Elist_Ids below (as 6726 -- otherwise, derived types that inherit constraints may appear 6727 -- to be unequal, because each level of derivation can have its 6728 -- own copy of the constraint). 6729 6730 function Original_Discriminant_Constraint 6731 (Typ : Entity_Id) return Elist_Id 6732 is 6733 begin 6734 if not Has_Discriminants (Typ) then 6735 return No_Elist; 6736 6737 -- If Typ is not a derived type, then directly return the 6738 -- its constraint. 6739 6740 elsif not Is_Derived_Type (Typ) then 6741 return Discriminant_Constraint (Typ); 6742 6743 -- If the parent type doesn't have discriminants, doesn't 6744 -- have a constraint, or has new discriminants, then stop 6745 -- and return Typ's constraint. 6746 6747 elsif not Has_Discriminants (Etype (Typ)) 6748 6749 -- No constraint on the parent type 6750 6751 or else not Present (Discriminant_Constraint (Etype (Typ))) 6752 or else Is_Empty_Elmt_List 6753 (Discriminant_Constraint (Etype (Typ))) 6754 6755 -- The parent type defines new discriminants 6756 6757 or else 6758 (Is_Base_Type (Etype (Typ)) 6759 and then Present (Discriminant_Specifications 6760 (Parent (Etype (Typ))))) 6761 then 6762 return Discriminant_Constraint (Typ); 6763 6764 -- Otherwise, make a recursive call on the parent type 6765 6766 else 6767 return Original_Discriminant_Constraint (Etype (Typ)); 6768 end if; 6769 end Original_Discriminant_Constraint; 6770 6771 -- Local variables 6772 6773 DL1 : constant Elist_Id := Original_Discriminant_Constraint (T1); 6774 DL2 : constant Elist_Id := Original_Discriminant_Constraint (T2); 6775 6776 DA1 : Elmt_Id; 6777 DA2 : Elmt_Id; 6778 6779 begin 6780 if DL1 = DL2 then 6781 return True; 6782 elsif Is_Constrained (T1) /= Is_Constrained (T2) then 6783 return False; 6784 end if; 6785 6786 -- Now loop through the discriminant constraints 6787 6788 -- Note: the guard here seems necessary, since it is possible at 6789 -- least for DL1 to be No_Elist. Not clear this is reasonable ??? 6790 6791 if Present (DL1) and then Present (DL2) then 6792 DA1 := First_Elmt (DL1); 6793 DA2 := First_Elmt (DL2); 6794 while Present (DA1) loop 6795 declare 6796 Expr1 : constant Node_Id := Node (DA1); 6797 Expr2 : constant Node_Id := Node (DA2); 6798 6799 begin 6800 if not Is_OK_Static_Expression (Expr1) 6801 or else not Is_OK_Static_Expression (Expr2) 6802 then 6803 return False; 6804 6805 -- If either expression raised a Constraint_Error, 6806 -- consider the expressions as matching, since this 6807 -- helps to prevent cascading errors. 6808 6809 elsif Raises_Constraint_Error (Expr1) 6810 or else Raises_Constraint_Error (Expr2) 6811 then 6812 null; 6813 6814 elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then 6815 return False; 6816 end if; 6817 end; 6818 6819 Next_Elmt (DA1); 6820 Next_Elmt (DA2); 6821 end loop; 6822 end if; 6823 end; 6824 6825 return True; 6826 6827 -- A definite type does not match an indefinite or classwide type. 6828 -- However, a generic type with unknown discriminants may be 6829 -- instantiated with a type with no discriminants, and conformance 6830 -- checking on an inherited operation may compare the actual with the 6831 -- subtype that renames it in the instance. 6832 6833 elsif Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2) 6834 then 6835 return 6836 Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2); 6837 6838 -- Array type 6839 6840 elsif Is_Array_Type (T1) then 6841 6842 -- If either subtype is unconstrained then both must be, and if both 6843 -- are unconstrained then no further checking is needed. 6844 6845 if not Is_Constrained (T1) or else not Is_Constrained (T2) then 6846 return not (Is_Constrained (T1) or else Is_Constrained (T2)); 6847 end if; 6848 6849 -- Both subtypes are constrained, so check that the index subtypes 6850 -- statically match. 6851 6852 declare 6853 Index1 : Node_Id := First_Index (T1); 6854 Index2 : Node_Id := First_Index (T2); 6855 6856 begin 6857 while Present (Index1) loop 6858 if not 6859 Subtypes_Statically_Match (Etype (Index1), Etype (Index2)) 6860 then 6861 return False; 6862 end if; 6863 6864 Next_Index (Index1); 6865 Next_Index (Index2); 6866 end loop; 6867 6868 return True; 6869 end; 6870 6871 elsif Is_Access_Type (T1) then 6872 if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then 6873 return False; 6874 6875 elsif Ekind (T1) in E_Access_Subprogram_Type 6876 | E_Anonymous_Access_Subprogram_Type 6877 then 6878 return 6879 Subtype_Conformant 6880 (Designated_Type (T1), 6881 Designated_Type (T2)); 6882 else 6883 return 6884 Subtypes_Statically_Match 6885 (Designated_Type (T1), 6886 Designated_Type (T2)) 6887 and then Is_Access_Constant (T1) = Is_Access_Constant (T2); 6888 end if; 6889 6890 -- All other types definitely match 6891 6892 else 6893 return True; 6894 end if; 6895 end Subtypes_Statically_Match; 6896 6897 ---------- 6898 -- Test -- 6899 ---------- 6900 6901 function Test (Cond : Boolean) return Uint is 6902 begin 6903 if Cond then 6904 return Uint_1; 6905 else 6906 return Uint_0; 6907 end if; 6908 end Test; 6909 6910 --------------------- 6911 -- Test_Comparison -- 6912 --------------------- 6913 6914 procedure Test_Comparison 6915 (Op : Node_Id; 6916 Assume_Valid : Boolean; 6917 True_Result : out Boolean; 6918 False_Result : out Boolean) 6919 is 6920 Left : constant Node_Id := Left_Opnd (Op); 6921 Left_Typ : constant Entity_Id := Etype (Left); 6922 Orig_Op : constant Node_Id := Original_Node (Op); 6923 6924 procedure Replacement_Warning (Msg : String); 6925 -- Emit a warning on a comparison that can be replaced by '=' 6926 6927 ------------------------- 6928 -- Replacement_Warning -- 6929 ------------------------- 6930 6931 procedure Replacement_Warning (Msg : String) is 6932 begin 6933 if Constant_Condition_Warnings 6934 and then Comes_From_Source (Orig_Op) 6935 and then Is_Integer_Type (Left_Typ) 6936 and then not Error_Posted (Op) 6937 and then not Has_Warnings_Off (Left_Typ) 6938 and then not In_Instance 6939 then 6940 Error_Msg_N (Msg, Op); 6941 end if; 6942 end Replacement_Warning; 6943 6944 -- Local variables 6945 6946 Res : constant Compare_Result := 6947 Compile_Time_Compare (Left, Right_Opnd (Op), Assume_Valid); 6948 6949 -- Start of processing for Test_Comparison 6950 6951 begin 6952 case N_Op_Compare (Nkind (Op)) is 6953 when N_Op_Eq => 6954 True_Result := Res = EQ; 6955 False_Result := Res = LT or else Res = GT or else Res = NE; 6956 6957 when N_Op_Ge => 6958 True_Result := Res in Compare_GE; 6959 False_Result := Res = LT; 6960 6961 if Res = LE and then Nkind (Orig_Op) = N_Op_Ge then 6962 Replacement_Warning 6963 ("can never be greater than, could replace by ""'=""?c?"); 6964 end if; 6965 6966 when N_Op_Gt => 6967 True_Result := Res = GT; 6968 False_Result := Res in Compare_LE; 6969 6970 when N_Op_Le => 6971 True_Result := Res in Compare_LE; 6972 False_Result := Res = GT; 6973 6974 if Res = GE and then Nkind (Orig_Op) = N_Op_Le then 6975 Replacement_Warning 6976 ("can never be less than, could replace by ""'=""?c?"); 6977 end if; 6978 6979 when N_Op_Lt => 6980 True_Result := Res = LT; 6981 False_Result := Res in Compare_GE; 6982 6983 when N_Op_Ne => 6984 True_Result := Res = NE or else Res = GT or else Res = LT; 6985 False_Result := Res = EQ; 6986 end case; 6987 end Test_Comparison; 6988 6989 --------------------------------- 6990 -- Test_Expression_Is_Foldable -- 6991 --------------------------------- 6992 6993 -- One operand case 6994 6995 procedure Test_Expression_Is_Foldable 6996 (N : Node_Id; 6997 Op1 : Node_Id; 6998 Stat : out Boolean; 6999 Fold : out Boolean) 7000 is 7001 begin 7002 Stat := False; 7003 Fold := False; 7004 7005 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then 7006 return; 7007 end if; 7008 7009 -- If operand is Any_Type, just propagate to result and do not 7010 -- try to fold, this prevents cascaded errors. 7011 7012 if Etype (Op1) = Any_Type then 7013 Set_Etype (N, Any_Type); 7014 return; 7015 7016 -- If operand raises Constraint_Error, then replace node N with the 7017 -- raise Constraint_Error node, and we are obviously not foldable. 7018 -- Note that this replacement inherits the Is_Static_Expression flag 7019 -- from the operand. 7020 7021 elsif Raises_Constraint_Error (Op1) then 7022 Rewrite_In_Raise_CE (N, Op1); 7023 return; 7024 7025 -- If the operand is not static, then the result is not static, and 7026 -- all we have to do is to check the operand since it is now known 7027 -- to appear in a non-static context. 7028 7029 elsif not Is_Static_Expression (Op1) then 7030 Check_Non_Static_Context (Op1); 7031 Fold := Compile_Time_Known_Value (Op1); 7032 return; 7033 7034 -- An expression of a formal modular type is not foldable because 7035 -- the modulus is unknown. 7036 7037 elsif Is_Modular_Integer_Type (Etype (Op1)) 7038 and then Is_Generic_Type (Etype (Op1)) 7039 then 7040 Check_Non_Static_Context (Op1); 7041 return; 7042 7043 -- Here we have the case of an operand whose type is OK, which is 7044 -- static, and which does not raise Constraint_Error, we can fold. 7045 7046 else 7047 Set_Is_Static_Expression (N); 7048 Fold := True; 7049 Stat := True; 7050 end if; 7051 end Test_Expression_Is_Foldable; 7052 7053 -- Two operand case 7054 7055 procedure Test_Expression_Is_Foldable 7056 (N : Node_Id; 7057 Op1 : Node_Id; 7058 Op2 : Node_Id; 7059 Stat : out Boolean; 7060 Fold : out Boolean; 7061 CRT_Safe : Boolean := False) 7062 is 7063 Rstat : constant Boolean := Is_Static_Expression (Op1) 7064 and then 7065 Is_Static_Expression (Op2); 7066 7067 begin 7068 Stat := False; 7069 Fold := False; 7070 7071 -- Inhibit folding if -gnatd.f flag set 7072 7073 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then 7074 return; 7075 end if; 7076 7077 -- If either operand is Any_Type, just propagate to result and 7078 -- do not try to fold, this prevents cascaded errors. 7079 7080 if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then 7081 Set_Etype (N, Any_Type); 7082 return; 7083 7084 -- If left operand raises Constraint_Error, then replace node N with the 7085 -- Raise_Constraint_Error node, and we are obviously not foldable. 7086 -- Is_Static_Expression is set from the two operands in the normal way, 7087 -- and we check the right operand if it is in a non-static context. 7088 7089 elsif Raises_Constraint_Error (Op1) then 7090 if not Rstat then 7091 Check_Non_Static_Context (Op2); 7092 end if; 7093 7094 Rewrite_In_Raise_CE (N, Op1); 7095 Set_Is_Static_Expression (N, Rstat); 7096 return; 7097 7098 -- Similar processing for the case of the right operand. Note that we 7099 -- don't use this routine for the short-circuit case, so we do not have 7100 -- to worry about that special case here. 7101 7102 elsif Raises_Constraint_Error (Op2) then 7103 if not Rstat then 7104 Check_Non_Static_Context (Op1); 7105 end if; 7106 7107 Rewrite_In_Raise_CE (N, Op2); 7108 Set_Is_Static_Expression (N, Rstat); 7109 return; 7110 7111 -- Exclude expressions of a generic modular type, as above 7112 7113 elsif Is_Modular_Integer_Type (Etype (Op1)) 7114 and then Is_Generic_Type (Etype (Op1)) 7115 then 7116 Check_Non_Static_Context (Op1); 7117 return; 7118 7119 -- If result is not static, then check non-static contexts on operands 7120 -- since one of them may be static and the other one may not be static. 7121 7122 elsif not Rstat then 7123 Check_Non_Static_Context (Op1); 7124 Check_Non_Static_Context (Op2); 7125 7126 if CRT_Safe then 7127 Fold := CRT_Safe_Compile_Time_Known_Value (Op1) 7128 and then CRT_Safe_Compile_Time_Known_Value (Op2); 7129 else 7130 Fold := Compile_Time_Known_Value (Op1) 7131 and then Compile_Time_Known_Value (Op2); 7132 end if; 7133 7134 return; 7135 7136 -- Else result is static and foldable. Both operands are static, and 7137 -- neither raises Constraint_Error, so we can definitely fold. 7138 7139 else 7140 Set_Is_Static_Expression (N); 7141 Fold := True; 7142 Stat := True; 7143 return; 7144 end if; 7145 end Test_Expression_Is_Foldable; 7146 7147 ------------------- 7148 -- Test_In_Range -- 7149 ------------------- 7150 7151 function Test_In_Range 7152 (N : Node_Id; 7153 Typ : Entity_Id; 7154 Assume_Valid : Boolean; 7155 Fixed_Int : Boolean; 7156 Int_Real : Boolean) return Range_Membership 7157 is 7158 Val : Uint; 7159 Valr : Ureal; 7160 7161 pragma Warnings (Off, Assume_Valid); 7162 -- For now Assume_Valid is unreferenced since the current implementation 7163 -- always returns Unknown if N is not a compile-time-known value, but we 7164 -- keep the parameter to allow for future enhancements in which we try 7165 -- to get the information in the variable case as well. 7166 7167 begin 7168 -- If an error was posted on expression, then return Unknown, we do not 7169 -- want cascaded errors based on some false analysis of a junk node. 7170 7171 if Error_Posted (N) then 7172 return Unknown; 7173 7174 -- Expression that raises Constraint_Error is an odd case. We certainly 7175 -- do not want to consider it to be in range. It might make sense to 7176 -- consider it always out of range, but this causes incorrect error 7177 -- messages about static expressions out of range. So we just return 7178 -- Unknown, which is always safe. 7179 7180 elsif Raises_Constraint_Error (N) then 7181 return Unknown; 7182 7183 -- Universal types have no range limits, so always in range 7184 7185 elsif Typ = Universal_Integer or else Typ = Universal_Real then 7186 return In_Range; 7187 7188 -- Never known if not scalar type. Don't know if this can actually 7189 -- happen, but our spec allows it, so we must check. 7190 7191 elsif not Is_Scalar_Type (Typ) then 7192 return Unknown; 7193 7194 -- Never known if this is a generic type, since the bounds of generic 7195 -- types are junk. Note that if we only checked for static expressions 7196 -- (instead of compile-time-known values) below, we would not need this 7197 -- check, because values of a generic type can never be static, but they 7198 -- can be known at compile time. 7199 7200 elsif Is_Generic_Type (Typ) then 7201 return Unknown; 7202 7203 -- Case of a known compile time value, where we can check if it is in 7204 -- the bounds of the given type. 7205 7206 elsif Compile_Time_Known_Value (N) then 7207 declare 7208 Lo : Node_Id; 7209 Hi : Node_Id; 7210 7211 LB_Known : Boolean; 7212 HB_Known : Boolean; 7213 7214 begin 7215 Lo := Type_Low_Bound (Typ); 7216 Hi := Type_High_Bound (Typ); 7217 7218 LB_Known := Compile_Time_Known_Value (Lo); 7219 HB_Known := Compile_Time_Known_Value (Hi); 7220 7221 -- Fixed point types should be considered as such only if flag 7222 -- Fixed_Int is set to False. 7223 7224 if Is_Floating_Point_Type (Typ) 7225 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) 7226 or else Int_Real 7227 then 7228 Valr := Expr_Value_R (N); 7229 7230 if LB_Known and HB_Known then 7231 if Valr >= Expr_Value_R (Lo) 7232 and then 7233 Valr <= Expr_Value_R (Hi) 7234 then 7235 return In_Range; 7236 else 7237 return Out_Of_Range; 7238 end if; 7239 7240 elsif (LB_Known and then Valr < Expr_Value_R (Lo)) 7241 or else 7242 (HB_Known and then Valr > Expr_Value_R (Hi)) 7243 then 7244 return Out_Of_Range; 7245 7246 else 7247 return Unknown; 7248 end if; 7249 7250 else 7251 Val := Expr_Value (N); 7252 7253 if LB_Known and HB_Known then 7254 if Val >= Expr_Value (Lo) and then Val <= Expr_Value (Hi) 7255 then 7256 return In_Range; 7257 else 7258 return Out_Of_Range; 7259 end if; 7260 7261 elsif (LB_Known and then Val < Expr_Value (Lo)) 7262 or else 7263 (HB_Known and then Val > Expr_Value (Hi)) 7264 then 7265 return Out_Of_Range; 7266 7267 else 7268 return Unknown; 7269 end if; 7270 end if; 7271 end; 7272 7273 -- Here for value not known at compile time. Case of expression subtype 7274 -- is Typ or is a subtype of Typ, and we can assume expression is valid. 7275 -- In this case we know it is in range without knowing its value. 7276 7277 elsif Assume_Valid 7278 and then (Etype (N) = Typ or else Is_Subtype_Of (Etype (N), Typ)) 7279 then 7280 return In_Range; 7281 7282 -- Another special case. For signed integer types, if the target type 7283 -- has Is_Known_Valid set, and the source type does not have a larger 7284 -- size, then the source value must be in range. We exclude biased 7285 -- types, because they bizarrely can generate out of range values. 7286 7287 elsif Is_Signed_Integer_Type (Etype (N)) 7288 and then Is_Known_Valid (Typ) 7289 and then Esize (Etype (N)) <= Esize (Typ) 7290 and then not Has_Biased_Representation (Etype (N)) 7291 then 7292 return In_Range; 7293 7294 -- For all other cases, result is unknown 7295 7296 else 7297 return Unknown; 7298 end if; 7299 end Test_In_Range; 7300 7301 -------------- 7302 -- To_Bits -- 7303 -------------- 7304 7305 procedure To_Bits (U : Uint; B : out Bits) is 7306 begin 7307 for J in 0 .. B'Last loop 7308 B (J) := (U / (2 ** J)) mod 2 /= 0; 7309 end loop; 7310 end To_Bits; 7311 7312 -------------------- 7313 -- Why_Not_Static -- 7314 -------------------- 7315 7316 procedure Why_Not_Static (Expr : Node_Id) is 7317 N : constant Node_Id := Original_Node (Expr); 7318 Typ : Entity_Id := Empty; 7319 E : Entity_Id; 7320 Alt : Node_Id; 7321 Exp : Node_Id; 7322 7323 procedure Why_Not_Static_List (L : List_Id); 7324 -- A version that can be called on a list of expressions. Finds all 7325 -- non-static violations in any element of the list. 7326 7327 ------------------------- 7328 -- Why_Not_Static_List -- 7329 ------------------------- 7330 7331 procedure Why_Not_Static_List (L : List_Id) is 7332 N : Node_Id; 7333 begin 7334 if Is_Non_Empty_List (L) then 7335 N := First (L); 7336 while Present (N) loop 7337 Why_Not_Static (N); 7338 Next (N); 7339 end loop; 7340 end if; 7341 end Why_Not_Static_List; 7342 7343 -- Start of processing for Why_Not_Static 7344 7345 begin 7346 -- Ignore call on error or empty node 7347 7348 if No (Expr) or else Nkind (Expr) = N_Error then 7349 return; 7350 end if; 7351 7352 -- Preprocessing for sub expressions 7353 7354 if Nkind (Expr) in N_Subexpr then 7355 7356 -- Nothing to do if expression is static 7357 7358 if Is_OK_Static_Expression (Expr) then 7359 return; 7360 end if; 7361 7362 -- Test for Constraint_Error raised 7363 7364 if Raises_Constraint_Error (Expr) then 7365 7366 -- Special case membership to find out which piece to flag 7367 7368 if Nkind (N) in N_Membership_Test then 7369 if Raises_Constraint_Error (Left_Opnd (N)) then 7370 Why_Not_Static (Left_Opnd (N)); 7371 return; 7372 7373 elsif Present (Right_Opnd (N)) 7374 and then Raises_Constraint_Error (Right_Opnd (N)) 7375 then 7376 Why_Not_Static (Right_Opnd (N)); 7377 return; 7378 7379 else 7380 pragma Assert (Present (Alternatives (N))); 7381 7382 Alt := First (Alternatives (N)); 7383 while Present (Alt) loop 7384 if Raises_Constraint_Error (Alt) then 7385 Why_Not_Static (Alt); 7386 return; 7387 else 7388 Next (Alt); 7389 end if; 7390 end loop; 7391 end if; 7392 7393 -- Special case a range to find out which bound to flag 7394 7395 elsif Nkind (N) = N_Range then 7396 if Raises_Constraint_Error (Low_Bound (N)) then 7397 Why_Not_Static (Low_Bound (N)); 7398 return; 7399 7400 elsif Raises_Constraint_Error (High_Bound (N)) then 7401 Why_Not_Static (High_Bound (N)); 7402 return; 7403 end if; 7404 7405 -- Special case attribute to see which part to flag 7406 7407 elsif Nkind (N) = N_Attribute_Reference then 7408 if Raises_Constraint_Error (Prefix (N)) then 7409 Why_Not_Static (Prefix (N)); 7410 return; 7411 end if; 7412 7413 if Present (Expressions (N)) then 7414 Exp := First (Expressions (N)); 7415 while Present (Exp) loop 7416 if Raises_Constraint_Error (Exp) then 7417 Why_Not_Static (Exp); 7418 return; 7419 end if; 7420 7421 Next (Exp); 7422 end loop; 7423 end if; 7424 7425 -- Special case a subtype name 7426 7427 elsif Is_Entity_Name (Expr) and then Is_Type (Entity (Expr)) then 7428 Error_Msg_NE 7429 ("!& is not a static subtype (RM 4.9(26))", N, Entity (Expr)); 7430 return; 7431 end if; 7432 7433 -- End of special cases 7434 7435 Error_Msg_N 7436 ("!expression raises exception, cannot be static (RM 4.9(34))", 7437 N); 7438 return; 7439 end if; 7440 7441 -- If no type, then something is pretty wrong, so ignore 7442 7443 Typ := Etype (Expr); 7444 7445 if No (Typ) then 7446 return; 7447 end if; 7448 7449 -- Type must be scalar or string type (but allow Bignum, since this 7450 -- is really a scalar type from our point of view in this diagnosis). 7451 7452 if not Is_Scalar_Type (Typ) 7453 and then not Is_String_Type (Typ) 7454 and then not Is_RTE (Typ, RE_Bignum) 7455 then 7456 Error_Msg_N 7457 ("!static expression must have scalar or string type " & 7458 "(RM 4.9(2))", N); 7459 return; 7460 end if; 7461 end if; 7462 7463 -- If we got through those checks, test particular node kind 7464 7465 case Nkind (N) is 7466 7467 -- Entity name 7468 7469 when N_Expanded_Name 7470 | N_Identifier 7471 | N_Operator_Symbol 7472 => 7473 E := Entity (N); 7474 7475 if Is_Named_Number (E) then 7476 null; 7477 7478 elsif Ekind (E) = E_Constant then 7479 7480 -- One case we can give a better message is when we have a 7481 -- string literal created by concatenating an aggregate with 7482 -- an others expression. 7483 7484 Entity_Case : declare 7485 CV : constant Node_Id := Constant_Value (E); 7486 CO : constant Node_Id := Original_Node (CV); 7487 7488 function Is_Aggregate (N : Node_Id) return Boolean; 7489 -- See if node N came from an others aggregate, if so 7490 -- return True and set Error_Msg_Sloc to aggregate. 7491 7492 ------------------ 7493 -- Is_Aggregate -- 7494 ------------------ 7495 7496 function Is_Aggregate (N : Node_Id) return Boolean is 7497 begin 7498 if Nkind (Original_Node (N)) = N_Aggregate then 7499 Error_Msg_Sloc := Sloc (Original_Node (N)); 7500 return True; 7501 7502 elsif Is_Entity_Name (N) 7503 and then Ekind (Entity (N)) = E_Constant 7504 and then 7505 Nkind (Original_Node (Constant_Value (Entity (N)))) = 7506 N_Aggregate 7507 then 7508 Error_Msg_Sloc := 7509 Sloc (Original_Node (Constant_Value (Entity (N)))); 7510 return True; 7511 7512 else 7513 return False; 7514 end if; 7515 end Is_Aggregate; 7516 7517 -- Start of processing for Entity_Case 7518 7519 begin 7520 if Is_Aggregate (CV) 7521 or else (Nkind (CO) = N_Op_Concat 7522 and then (Is_Aggregate (Left_Opnd (CO)) 7523 or else 7524 Is_Aggregate (Right_Opnd (CO)))) 7525 then 7526 Error_Msg_N ("!aggregate (#) is never static", N); 7527 7528 elsif No (CV) or else not Is_Static_Expression (CV) then 7529 Error_Msg_NE 7530 ("!& is not a static constant (RM 4.9(5))", N, E); 7531 end if; 7532 end Entity_Case; 7533 7534 elsif Is_Type (E) then 7535 Error_Msg_NE 7536 ("!& is not a static subtype (RM 4.9(26))", N, E); 7537 7538 else 7539 Error_Msg_NE 7540 ("!& is not static constant or named number " 7541 & "(RM 4.9(5))", N, E); 7542 end if; 7543 7544 -- Binary operator 7545 7546 when N_Binary_Op 7547 | N_Membership_Test 7548 | N_Short_Circuit 7549 => 7550 if Nkind (N) in N_Op_Shift then 7551 Error_Msg_N 7552 ("!shift functions are never static (RM 4.9(6,18))", N); 7553 else 7554 Why_Not_Static (Left_Opnd (N)); 7555 Why_Not_Static (Right_Opnd (N)); 7556 end if; 7557 7558 -- Unary operator 7559 7560 when N_Unary_Op => 7561 Why_Not_Static (Right_Opnd (N)); 7562 7563 -- Attribute reference 7564 7565 when N_Attribute_Reference => 7566 Why_Not_Static_List (Expressions (N)); 7567 7568 E := Etype (Prefix (N)); 7569 7570 if E = Standard_Void_Type then 7571 return; 7572 end if; 7573 7574 -- Special case non-scalar'Size since this is a common error 7575 7576 if Attribute_Name (N) = Name_Size then 7577 Error_Msg_N 7578 ("!size attribute is only static for static scalar type " 7579 & "(RM 4.9(7,8))", N); 7580 7581 -- Flag array cases 7582 7583 elsif Is_Array_Type (E) then 7584 if Attribute_Name (N) 7585 not in Name_First | Name_Last | Name_Length 7586 then 7587 Error_Msg_N 7588 ("!static array attribute must be Length, First, or Last " 7589 & "(RM 4.9(8))", N); 7590 7591 -- Since we know the expression is not-static (we already 7592 -- tested for this, must mean array is not static). 7593 7594 else 7595 Error_Msg_N 7596 ("!prefix is non-static array (RM 4.9(8))", Prefix (N)); 7597 end if; 7598 7599 return; 7600 7601 -- Special case generic types, since again this is a common source 7602 -- of confusion. 7603 7604 elsif Is_Generic_Actual_Type (E) or else Is_Generic_Type (E) then 7605 Error_Msg_N 7606 ("!attribute of generic type is never static " 7607 & "(RM 4.9(7,8))", N); 7608 7609 elsif Is_OK_Static_Subtype (E) then 7610 null; 7611 7612 elsif Is_Scalar_Type (E) then 7613 Error_Msg_N 7614 ("!prefix type for attribute is not static scalar subtype " 7615 & "(RM 4.9(7))", N); 7616 7617 else 7618 Error_Msg_N 7619 ("!static attribute must apply to array/scalar type " 7620 & "(RM 4.9(7,8))", N); 7621 end if; 7622 7623 -- String literal 7624 7625 when N_String_Literal => 7626 Error_Msg_N 7627 ("!subtype of string literal is non-static (RM 4.9(4))", N); 7628 7629 -- Explicit dereference 7630 7631 when N_Explicit_Dereference => 7632 Error_Msg_N 7633 ("!explicit dereference is never static (RM 4.9)", N); 7634 7635 -- Function call 7636 7637 when N_Function_Call => 7638 Why_Not_Static_List (Parameter_Associations (N)); 7639 7640 -- Complain about non-static function call unless we have Bignum 7641 -- which means that the underlying expression is really some 7642 -- scalar arithmetic operation. 7643 7644 if not Is_RTE (Typ, RE_Bignum) then 7645 Error_Msg_N ("!non-static function call (RM 4.9(6,18))", N); 7646 end if; 7647 7648 -- Parameter assocation (test actual parameter) 7649 7650 when N_Parameter_Association => 7651 Why_Not_Static (Explicit_Actual_Parameter (N)); 7652 7653 -- Indexed component 7654 7655 when N_Indexed_Component => 7656 Error_Msg_N ("!indexed component is never static (RM 4.9)", N); 7657 7658 -- Procedure call 7659 7660 when N_Procedure_Call_Statement => 7661 Error_Msg_N ("!procedure call is never static (RM 4.9)", N); 7662 7663 -- Qualified expression (test expression) 7664 7665 when N_Qualified_Expression => 7666 Why_Not_Static (Expression (N)); 7667 7668 -- Aggregate 7669 7670 when N_Aggregate 7671 | N_Extension_Aggregate 7672 => 7673 Error_Msg_N ("!an aggregate is never static (RM 4.9)", N); 7674 7675 -- Range 7676 7677 when N_Range => 7678 Why_Not_Static (Low_Bound (N)); 7679 Why_Not_Static (High_Bound (N)); 7680 7681 -- Range constraint, test range expression 7682 7683 when N_Range_Constraint => 7684 Why_Not_Static (Range_Expression (N)); 7685 7686 -- Subtype indication, test constraint 7687 7688 when N_Subtype_Indication => 7689 Why_Not_Static (Constraint (N)); 7690 7691 -- Selected component 7692 7693 when N_Selected_Component => 7694 Error_Msg_N ("!selected component is never static (RM 4.9)", N); 7695 7696 -- Slice 7697 7698 when N_Slice => 7699 Error_Msg_N ("!slice is never static (RM 4.9)", N); 7700 7701 when N_Type_Conversion => 7702 Why_Not_Static (Expression (N)); 7703 7704 if not Is_Scalar_Type (Entity (Subtype_Mark (N))) 7705 or else not Is_OK_Static_Subtype (Entity (Subtype_Mark (N))) 7706 then 7707 Error_Msg_N 7708 ("!static conversion requires static scalar subtype result " 7709 & "(RM 4.9(9))", N); 7710 end if; 7711 7712 -- Unchecked type conversion 7713 7714 when N_Unchecked_Type_Conversion => 7715 Error_Msg_N 7716 ("!unchecked type conversion is never static (RM 4.9)", N); 7717 7718 -- All other cases, no reason to give 7719 7720 when others => 7721 null; 7722 end case; 7723 end Why_Not_Static; 7724 7725end Sem_Eval; 7726