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