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