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