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