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-2003 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Checks; use Checks; 29with Debug; use Debug; 30with Einfo; use Einfo; 31with Elists; use Elists; 32with Errout; use Errout; 33with Eval_Fat; use Eval_Fat; 34with Exp_Util; use Exp_Util; 35with Nmake; use Nmake; 36with Nlists; use Nlists; 37with Opt; use Opt; 38with Sem; use Sem; 39with Sem_Cat; use Sem_Cat; 40with Sem_Ch8; use Sem_Ch8; 41with Sem_Res; use Sem_Res; 42with Sem_Util; use Sem_Util; 43with Sem_Type; use Sem_Type; 44with Sem_Warn; use Sem_Warn; 45with Sinfo; use Sinfo; 46with Snames; use Snames; 47with Stand; use Stand; 48with Stringt; use Stringt; 49with Tbuild; use Tbuild; 50 51package body Sem_Eval is 52 53 ----------------------------------------- 54 -- Handling of Compile Time Evaluation -- 55 ----------------------------------------- 56 57 -- The compile time evaluation of expressions is distributed over several 58 -- Eval_xxx procedures. These procedures are called immediatedly after 59 -- a subexpression is resolved and is therefore accomplished in a bottom 60 -- up fashion. The flags are synthesized using the following approach. 61 62 -- Is_Static_Expression is determined by following the detailed rules 63 -- in RM 4.9(4-14). This involves testing the Is_Static_Expression 64 -- flag of the operands in many cases. 65 66 -- Raises_Constraint_Error is set if any of the operands have the flag 67 -- set or if an attempt to compute the value of the current expression 68 -- results in detection of a runtime constraint error. 69 70 -- As described in the spec, the requirement is that Is_Static_Expression 71 -- be accurately set, and in addition for nodes for which this flag is set, 72 -- Raises_Constraint_Error must also be set. Furthermore a node which has 73 -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the 74 -- requirement is that the expression value must be precomputed, and the 75 -- node is either a literal, or the name of a constant entity whose value 76 -- is a static expression. 77 78 -- The general approach is as follows. First compute Is_Static_Expression. 79 -- If the node is not static, then the flag is left off in the node and 80 -- we are all done. Otherwise for a static node, we test if any of the 81 -- operands will raise constraint error, and if so, propagate the flag 82 -- Raises_Constraint_Error to the result node and we are done (since the 83 -- error was already posted at a lower level). 84 85 -- For the case of a static node whose operands do not raise constraint 86 -- error, we attempt to evaluate the node. If this evaluation succeeds, 87 -- then the node is replaced by the result of this computation. If the 88 -- evaluation raises constraint error, then we rewrite the node with 89 -- Apply_Compile_Time_Constraint_Error to raise the exception and also 90 -- to post appropriate error messages. 91 92 ---------------- 93 -- Local Data -- 94 ---------------- 95 96 type Bits is array (Nat range <>) of Boolean; 97 -- Used to convert unsigned (modular) values for folding logical ops 98 99 -- The following definitions are used to maintain a cache of nodes that 100 -- have compile time known values. The cache is maintained only for 101 -- discrete types (the most common case), and is populated by calls to 102 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value 103 -- since it is possible for the status to change (in particular it is 104 -- possible for a node to get replaced by a constraint error node). 105 106 CV_Bits : constant := 5; 107 -- Number of low order bits of Node_Id value used to reference entries 108 -- in the cache table. 109 110 CV_Cache_Size : constant Nat := 2 ** CV_Bits; 111 -- Size of cache for compile time values 112 113 subtype CV_Range is Nat range 0 .. CV_Cache_Size; 114 115 type CV_Entry is record 116 N : Node_Id; 117 V : Uint; 118 end record; 119 120 type CV_Cache_Array is array (CV_Range) of CV_Entry; 121 122 CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0)); 123 -- This is the actual cache, with entries consisting of node/value pairs, 124 -- and the impossible value Node_High_Bound used for unset entries. 125 126 ----------------------- 127 -- Local Subprograms -- 128 ----------------------- 129 130 function From_Bits (B : Bits; T : Entity_Id) return Uint; 131 -- Converts a bit string of length B'Length to a Uint value to be used 132 -- for a target of type T, which is a modular type. This procedure 133 -- includes the necessary reduction by the modulus in the case of a 134 -- non-binary modulus (for a binary modulus, the bit string is the 135 -- right length any way so all is well). 136 137 function Get_String_Val (N : Node_Id) return Node_Id; 138 -- Given a tree node for a folded string or character value, returns 139 -- the corresponding string literal or character literal (one of the 140 -- two must be available, or the operand would not have been marked 141 -- as foldable in the earlier analysis of the operation). 142 143 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean; 144 -- Bits represents the number of bits in an integer value to be computed 145 -- (but the value has not been computed yet). If this value in Bits is 146 -- reasonable, a result of True is returned, with the implication that 147 -- the caller should go ahead and complete the calculation. If the value 148 -- in Bits is unreasonably large, then an error is posted on node N, and 149 -- False is returned (and the caller skips the proposed calculation). 150 151 procedure Out_Of_Range (N : Node_Id); 152 -- This procedure is called if it is determined that node N, which 153 -- appears in a non-static context, is a compile time known value 154 -- which is outside its range, i.e. the range of Etype. This is used 155 -- in contexts where this is an illegality if N is static, and should 156 -- generate a warning otherwise. 157 158 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id); 159 -- N and Exp are nodes representing an expression, Exp is known 160 -- to raise CE. N is rewritten in term of Exp in the optimal way. 161 162 function String_Type_Len (Stype : Entity_Id) return Uint; 163 -- Given a string type, determines the length of the index type, or, 164 -- if this index type is non-static, the length of the base type of 165 -- this index type. Note that if the string type is itself static, 166 -- then the index type is static, so the second case applies only 167 -- if the string type passed is non-static. 168 169 function Test (Cond : Boolean) return Uint; 170 pragma Inline (Test); 171 -- This function simply returns the appropriate Boolean'Pos value 172 -- corresponding to the value of Cond as a universal integer. It is 173 -- used for producing the result of the static evaluation of the 174 -- logical operators 175 176 procedure Test_Expression_Is_Foldable 177 (N : Node_Id; 178 Op1 : Node_Id; 179 Stat : out Boolean; 180 Fold : out Boolean); 181 -- Tests to see if expression N whose single operand is Op1 is foldable, 182 -- i.e. the operand value is known at compile time. If the operation is 183 -- foldable, then Fold is True on return, and Stat indicates whether 184 -- the result is static (i.e. both operands were static). Note that it 185 -- is quite possible for Fold to be True, and Stat to be False, since 186 -- there are cases in which we know the value of an operand even though 187 -- it is not technically static (e.g. the static lower bound of a range 188 -- whose upper bound is non-static). 189 -- 190 -- If Stat is set False on return, then Expression_Is_Foldable makes a 191 -- call to Check_Non_Static_Context on the operand. If Fold is False on 192 -- return, then all processing is complete, and the caller should 193 -- return, since there is nothing else to do. 194 195 procedure Test_Expression_Is_Foldable 196 (N : Node_Id; 197 Op1 : Node_Id; 198 Op2 : Node_Id; 199 Stat : out Boolean; 200 Fold : out Boolean); 201 -- Same processing, except applies to an expression N with two operands 202 -- Op1 and Op2. 203 204 procedure To_Bits (U : Uint; B : out Bits); 205 -- Converts a Uint value to a bit string of length B'Length 206 207 ------------------------------ 208 -- Check_Non_Static_Context -- 209 ------------------------------ 210 211 procedure Check_Non_Static_Context (N : Node_Id) is 212 T : constant Entity_Id := Etype (N); 213 Checks_On : constant Boolean := 214 not Index_Checks_Suppressed (T) 215 and not Range_Checks_Suppressed (T); 216 217 begin 218 -- Ignore cases of non-scalar types or error types 219 220 if T = Any_Type or else not Is_Scalar_Type (T) then 221 return; 222 end if; 223 224 -- At this stage we have a scalar type. If we have an expression 225 -- that raises CE, then we already issued a warning or error msg 226 -- so there is nothing more to be done in this routine. 227 228 if Raises_Constraint_Error (N) then 229 return; 230 end if; 231 232 -- Now we have a scalar type which is not marked as raising a 233 -- constraint error exception. The main purpose of this routine 234 -- is to deal with static expressions appearing in a non-static 235 -- context. That means that if we do not have a static expression 236 -- then there is not much to do. The one case that we deal with 237 -- here is that if we have a floating-point value that is out of 238 -- range, then we post a warning that an infinity will result. 239 240 if not Is_Static_Expression (N) then 241 if Is_Floating_Point_Type (T) 242 and then Is_Out_Of_Range (N, Base_Type (T)) 243 then 244 Error_Msg_N 245 ("?float value out of range, infinity will be generated", N); 246 end if; 247 248 return; 249 end if; 250 251 -- Here we have the case of outer level static expression of 252 -- scalar type, where the processing of this procedure is needed. 253 254 -- For real types, this is where we convert the value to a machine 255 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should 256 -- only need to do this if the parent is a constant declaration, 257 -- since in other cases, gigi should do the necessary conversion 258 -- correctly, but experimentation shows that this is not the case 259 -- on all machines, in particular if we do not convert all literals 260 -- to machine values in non-static contexts, then ACVC test C490001 261 -- fails on Sparc/Solaris and SGI/Irix. 262 263 if Nkind (N) = N_Real_Literal 264 and then not Is_Machine_Number (N) 265 and then not Is_Generic_Type (Etype (N)) 266 and then Etype (N) /= Universal_Real 267 then 268 -- Check that value is in bounds before converting to machine 269 -- number, so as not to lose case where value overflows in the 270 -- least significant bit or less. See B490001. 271 272 if Is_Out_Of_Range (N, Base_Type (T)) then 273 Out_Of_Range (N); 274 return; 275 end if; 276 277 -- Note: we have to copy the node, to avoid problems with conformance 278 -- of very similar numbers (see ACVC tests B4A010C and B63103A). 279 280 Rewrite (N, New_Copy (N)); 281 282 if not Is_Floating_Point_Type (T) then 283 Set_Realval 284 (N, Corresponding_Integer_Value (N) * Small_Value (T)); 285 286 elsif not UR_Is_Zero (Realval (N)) then 287 288 -- Note: even though RM 4.9(38) specifies biased rounding, 289 -- this has been modified by AI-100 in order to prevent 290 -- confusing differences in rounding between static and 291 -- non-static expressions. AI-100 specifies that the effect 292 -- of such rounding is implementation dependent, and in GNAT 293 -- we round to nearest even to match the run-time behavior. 294 295 Set_Realval 296 (N, Machine (Base_Type (T), Realval (N), Round_Even, N)); 297 end if; 298 299 Set_Is_Machine_Number (N); 300 end if; 301 302 -- Check for out of range universal integer. This is a non-static 303 -- context, so the integer value must be in range of the runtime 304 -- representation of universal integers. 305 306 -- We do this only within an expression, because that is the only 307 -- case in which non-static universal integer values can occur, and 308 -- furthermore, Check_Non_Static_Context is currently (incorrectly???) 309 -- called in contexts like the expression of a number declaration where 310 -- we certainly want to allow out of range values. 311 312 if Etype (N) = Universal_Integer 313 and then Nkind (N) = N_Integer_Literal 314 and then Nkind (Parent (N)) in N_Subexpr 315 and then 316 (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer)) 317 or else 318 Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer))) 319 then 320 Apply_Compile_Time_Constraint_Error 321 (N, "non-static universal integer value out of range?", 322 CE_Range_Check_Failed); 323 324 -- Check out of range of base type 325 326 elsif Is_Out_Of_Range (N, Base_Type (T)) then 327 Out_Of_Range (N); 328 329 -- Give warning if outside subtype (where one or both of the 330 -- bounds of the subtype is static). This warning is omitted 331 -- if the expression appears in a range that could be null 332 -- (warnings are handled elsewhere for this case). 333 334 elsif T /= Base_Type (T) 335 and then Nkind (Parent (N)) /= N_Range 336 then 337 if Is_In_Range (N, T) then 338 null; 339 340 elsif Is_Out_Of_Range (N, T) then 341 Apply_Compile_Time_Constraint_Error 342 (N, "value not in range of}?", CE_Range_Check_Failed); 343 344 elsif Checks_On then 345 Enable_Range_Check (N); 346 347 else 348 Set_Do_Range_Check (N, False); 349 end if; 350 end if; 351 end Check_Non_Static_Context; 352 353 --------------------------------- 354 -- Check_String_Literal_Length -- 355 --------------------------------- 356 357 procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is 358 begin 359 if not Raises_Constraint_Error (N) 360 and then Is_Constrained (Ttype) 361 then 362 if 363 UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype) 364 then 365 Apply_Compile_Time_Constraint_Error 366 (N, "string length wrong for}?", 367 CE_Length_Check_Failed, 368 Ent => Ttype, 369 Typ => Ttype); 370 end if; 371 end if; 372 end Check_String_Literal_Length; 373 374 -------------------------- 375 -- Compile_Time_Compare -- 376 -------------------------- 377 378 function Compile_Time_Compare 379 (L, R : Node_Id; 380 Rec : Boolean := False) 381 return Compare_Result 382 is 383 Ltyp : constant Entity_Id := Etype (L); 384 Rtyp : constant Entity_Id := Etype (R); 385 386 procedure Compare_Decompose 387 (N : Node_Id; 388 R : out Node_Id; 389 V : out Uint); 390 -- This procedure decomposes the node N into an expression node 391 -- and a signed offset, so that the value of N is equal to the 392 -- value of R plus the value V (which may be negative). If no 393 -- such decomposition is possible, then on return R is a copy 394 -- of N, and V is set to zero. 395 396 function Compare_Fixup (N : Node_Id) return Node_Id; 397 -- This function deals with replacing 'Last and 'First references 398 -- with their corresponding type bounds, which we then can compare. 399 -- The argument is the original node, the result is the identity, 400 -- unless we have a 'Last/'First reference in which case the value 401 -- returned is the appropriate type bound. 402 403 function Is_Same_Value (L, R : Node_Id) return Boolean; 404 -- Returns True iff L and R represent expressions that definitely 405 -- have identical (but not necessarily compile time known) values 406 -- Indeed the caller is expected to have already dealt with the 407 -- cases of compile time known values, so these are not tested here. 408 409 ----------------------- 410 -- Compare_Decompose -- 411 ----------------------- 412 413 procedure Compare_Decompose 414 (N : Node_Id; 415 R : out Node_Id; 416 V : out Uint) 417 is 418 begin 419 if Nkind (N) = N_Op_Add 420 and then Nkind (Right_Opnd (N)) = N_Integer_Literal 421 then 422 R := Left_Opnd (N); 423 V := Intval (Right_Opnd (N)); 424 return; 425 426 elsif Nkind (N) = N_Op_Subtract 427 and then Nkind (Right_Opnd (N)) = N_Integer_Literal 428 then 429 R := Left_Opnd (N); 430 V := UI_Negate (Intval (Right_Opnd (N))); 431 return; 432 433 elsif Nkind (N) = N_Attribute_Reference then 434 435 if Attribute_Name (N) = Name_Succ then 436 R := First (Expressions (N)); 437 V := Uint_1; 438 return; 439 440 elsif Attribute_Name (N) = Name_Pred then 441 R := First (Expressions (N)); 442 V := Uint_Minus_1; 443 return; 444 end if; 445 end if; 446 447 R := N; 448 V := Uint_0; 449 end Compare_Decompose; 450 451 ------------------- 452 -- Compare_Fixup -- 453 ------------------- 454 455 function Compare_Fixup (N : Node_Id) return Node_Id is 456 Indx : Node_Id; 457 Xtyp : Entity_Id; 458 Subs : Nat; 459 460 begin 461 if Nkind (N) = N_Attribute_Reference 462 and then (Attribute_Name (N) = Name_First 463 or else 464 Attribute_Name (N) = Name_Last) 465 then 466 Xtyp := Etype (Prefix (N)); 467 468 -- If we have no type, then just abandon the attempt to do 469 -- a fixup, this is probably the result of some other error. 470 471 if No (Xtyp) then 472 return N; 473 end if; 474 475 -- Dereference an access type 476 477 if Is_Access_Type (Xtyp) then 478 Xtyp := Designated_Type (Xtyp); 479 end if; 480 481 -- If we don't have an array type at this stage, something 482 -- is peculiar, e.g. another error, and we abandon the attempt 483 -- at a fixup. 484 485 if not Is_Array_Type (Xtyp) then 486 return N; 487 end if; 488 489 -- Ignore unconstrained array, since bounds are not meaningful 490 491 if not Is_Constrained (Xtyp) then 492 return N; 493 end if; 494 495 if Ekind (Xtyp) = E_String_Literal_Subtype then 496 if Attribute_Name (N) = Name_First then 497 return String_Literal_Low_Bound (Xtyp); 498 499 else -- Attribute_Name (N) = Name_Last 500 return Make_Integer_Literal (Sloc (N), 501 Intval => Intval (String_Literal_Low_Bound (Xtyp)) 502 + String_Literal_Length (Xtyp)); 503 end if; 504 end if; 505 506 -- Find correct index type 507 508 Indx := First_Index (Xtyp); 509 510 if Present (Expressions (N)) then 511 Subs := UI_To_Int (Expr_Value (First (Expressions (N)))); 512 513 for J in 2 .. Subs loop 514 Indx := Next_Index (Indx); 515 end loop; 516 end if; 517 518 Xtyp := Etype (Indx); 519 520 if Attribute_Name (N) = Name_First then 521 return Type_Low_Bound (Xtyp); 522 523 else -- Attribute_Name (N) = Name_Last 524 return Type_High_Bound (Xtyp); 525 end if; 526 end if; 527 528 return N; 529 end Compare_Fixup; 530 531 ------------------- 532 -- Is_Same_Value -- 533 ------------------- 534 535 function Is_Same_Value (L, R : Node_Id) return Boolean is 536 Lf : constant Node_Id := Compare_Fixup (L); 537 Rf : constant Node_Id := Compare_Fixup (R); 538 539 function Is_Same_Subscript (L, R : List_Id) return Boolean; 540 -- L, R are the Expressions values from two attribute nodes 541 -- for First or Last attributes. Either may be set to No_List 542 -- if no expressions are present (indicating subscript 1). 543 -- The result is True if both expressions represent the same 544 -- subscript (note that one case is where one subscript is 545 -- missing and the other is explicitly set to 1). 546 547 ----------------------- 548 -- Is_Same_Subscript -- 549 ----------------------- 550 551 function Is_Same_Subscript (L, R : List_Id) return Boolean is 552 begin 553 if L = No_List then 554 if R = No_List then 555 return True; 556 else 557 return Expr_Value (First (R)) = Uint_1; 558 end if; 559 560 else 561 if R = No_List then 562 return Expr_Value (First (L)) = Uint_1; 563 else 564 return Expr_Value (First (L)) = Expr_Value (First (R)); 565 end if; 566 end if; 567 end Is_Same_Subscript; 568 569 -- Start of processing for Is_Same_Value 570 571 begin 572 -- Values are the same if they are the same identifier and the 573 -- identifier refers to a constant object (E_Constant). This 574 -- does not however apply to Float types, since we may have two 575 -- NaN values and they should never compare equal. 576 577 if Nkind (Lf) = N_Identifier and then Nkind (Rf) = N_Identifier 578 and then Entity (Lf) = Entity (Rf) 579 and then not Is_Floating_Point_Type (Etype (L)) 580 and then (Ekind (Entity (Lf)) = E_Constant or else 581 Ekind (Entity (Lf)) = E_In_Parameter or else 582 Ekind (Entity (Lf)) = E_Loop_Parameter) 583 then 584 return True; 585 586 -- Or if they are compile time known and identical 587 588 elsif Compile_Time_Known_Value (Lf) 589 and then 590 Compile_Time_Known_Value (Rf) 591 and then Expr_Value (Lf) = Expr_Value (Rf) 592 then 593 return True; 594 595 -- Or if they are both 'First or 'Last values applying to the 596 -- same entity (first and last don't change even if value does) 597 598 elsif Nkind (Lf) = N_Attribute_Reference 599 and then 600 Nkind (Rf) = N_Attribute_Reference 601 and then Attribute_Name (Lf) = Attribute_Name (Rf) 602 and then (Attribute_Name (Lf) = Name_First 603 or else 604 Attribute_Name (Lf) = Name_Last) 605 and then Is_Entity_Name (Prefix (Lf)) 606 and then Is_Entity_Name (Prefix (Rf)) 607 and then Entity (Prefix (Lf)) = Entity (Prefix (Rf)) 608 and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf)) 609 then 610 return True; 611 612 -- All other cases, we can't tell 613 614 else 615 return False; 616 end if; 617 end Is_Same_Value; 618 619 -- Start of processing for Compile_Time_Compare 620 621 begin 622 -- If either operand could raise constraint error, then we cannot 623 -- know the result at compile time (since CE may be raised!) 624 625 if not (Cannot_Raise_Constraint_Error (L) 626 and then 627 Cannot_Raise_Constraint_Error (R)) 628 then 629 return Unknown; 630 end if; 631 632 -- Identical operands are most certainly equal 633 634 if L = R then 635 return EQ; 636 637 -- If expressions have no types, then do not attempt to determine 638 -- if they are the same, since something funny is going on. One 639 -- case in which this happens is during generic template analysis, 640 -- when bounds are not fully analyzed. 641 642 elsif No (Ltyp) or else No (Rtyp) then 643 return Unknown; 644 645 -- We only attempt compile time analysis for scalar values, and 646 -- not for packed arrays represented as modular types, where the 647 -- semantics of comparison is quite different. 648 649 elsif not Is_Scalar_Type (Ltyp) 650 or else Is_Packed_Array_Type (Ltyp) 651 then 652 return Unknown; 653 654 -- Case where comparison involves two compile time known values 655 656 elsif Compile_Time_Known_Value (L) 657 and then Compile_Time_Known_Value (R) 658 then 659 -- For the floating-point case, we have to be a little careful, since 660 -- at compile time we are dealing with universal exact values, but at 661 -- runtime, these will be in non-exact target form. That's why the 662 -- returned results are LE and GE below instead of LT and GT. 663 664 if Is_Floating_Point_Type (Ltyp) 665 or else 666 Is_Floating_Point_Type (Rtyp) 667 then 668 declare 669 Lo : constant Ureal := Expr_Value_R (L); 670 Hi : constant Ureal := Expr_Value_R (R); 671 672 begin 673 if Lo < Hi then 674 return LE; 675 elsif Lo = Hi then 676 return EQ; 677 else 678 return GE; 679 end if; 680 end; 681 682 -- For the integer case we know exactly (note that this includes the 683 -- fixed-point case, where we know the run time integer values now) 684 685 else 686 declare 687 Lo : constant Uint := Expr_Value (L); 688 Hi : constant Uint := Expr_Value (R); 689 690 begin 691 if Lo < Hi then 692 return LT; 693 elsif Lo = Hi then 694 return EQ; 695 else 696 return GT; 697 end if; 698 end; 699 end if; 700 701 -- Cases where at least one operand is not known at compile time 702 703 else 704 -- Here is where we check for comparisons against maximum bounds of 705 -- types, where we know that no value can be outside the bounds of 706 -- the subtype. Note that this routine is allowed to assume that all 707 -- expressions are within their subtype bounds. Callers wishing to 708 -- deal with possibly invalid values must in any case take special 709 -- steps (e.g. conversions to larger types) to avoid this kind of 710 -- optimization, which is always considered to be valid. We do not 711 -- attempt this optimization with generic types, since the type 712 -- bounds may not be meaningful in this case. 713 714 -- We are in danger of an infinite recursion here. It does not seem 715 -- useful to go more than one level deep, so the parameter Rec is 716 -- used to protect ourselves against this infinite recursion. 717 718 if not Rec 719 and then Is_Discrete_Type (Ltyp) 720 and then Is_Discrete_Type (Rtyp) 721 and then not Is_Generic_Type (Ltyp) 722 and then not Is_Generic_Type (Rtyp) 723 then 724 -- See if we can get a decisive check against one operand and 725 -- a bound of the other operand (four possible tests here). 726 727 case Compile_Time_Compare (L, Type_Low_Bound (Rtyp), True) is 728 when LT => return LT; 729 when LE => return LE; 730 when EQ => return LE; 731 when others => null; 732 end case; 733 734 case Compile_Time_Compare (L, Type_High_Bound (Rtyp), True) is 735 when GT => return GT; 736 when GE => return GE; 737 when EQ => return GE; 738 when others => null; 739 end case; 740 741 case Compile_Time_Compare (Type_Low_Bound (Ltyp), R, True) is 742 when GT => return GT; 743 when GE => return GE; 744 when EQ => return GE; 745 when others => null; 746 end case; 747 748 case Compile_Time_Compare (Type_High_Bound (Ltyp), R, True) is 749 when LT => return LT; 750 when LE => return LE; 751 when EQ => return LE; 752 when others => null; 753 end case; 754 end if; 755 756 -- Next attempt is to decompose the expressions to extract 757 -- a constant offset resulting from the use of any of the forms: 758 759 -- expr + literal 760 -- expr - literal 761 -- typ'Succ (expr) 762 -- typ'Pred (expr) 763 764 -- Then we see if the two expressions are the same value, and if so 765 -- the result is obtained by comparing the offsets. 766 767 declare 768 Lnode : Node_Id; 769 Loffs : Uint; 770 Rnode : Node_Id; 771 Roffs : Uint; 772 773 begin 774 Compare_Decompose (L, Lnode, Loffs); 775 Compare_Decompose (R, Rnode, Roffs); 776 777 if Is_Same_Value (Lnode, Rnode) then 778 if Loffs = Roffs then 779 return EQ; 780 781 elsif Loffs < Roffs then 782 return LT; 783 784 else 785 return GT; 786 end if; 787 788 -- If the expressions are different, we cannot say at compile 789 -- time how they compare, so we return the Unknown indication. 790 791 else 792 return Unknown; 793 end if; 794 end; 795 end if; 796 end Compile_Time_Compare; 797 798 ------------------------------ 799 -- Compile_Time_Known_Value -- 800 ------------------------------ 801 802 function Compile_Time_Known_Value (Op : Node_Id) return Boolean is 803 K : constant Node_Kind := Nkind (Op); 804 CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size); 805 806 begin 807 -- Never known at compile time if bad type or raises constraint error 808 -- or empty (latter case occurs only as a result of a previous error) 809 810 if No (Op) 811 or else Op = Error 812 or else Etype (Op) = Any_Type 813 or else Raises_Constraint_Error (Op) 814 then 815 return False; 816 end if; 817 818 -- If this is not a static expression and we are in configurable run 819 -- time mode, then we consider it not known at compile time. This 820 -- avoids anomalies where whether something is permitted with a given 821 -- configurable run-time library depends on how good the compiler is 822 -- at optimizing and knowing that things are constant when they 823 -- are non-static. 824 825 if Configurable_Run_Time_Mode and then not Is_Static_Expression (Op) then 826 return False; 827 end if; 828 829 -- If we have an entity name, then see if it is the name of a constant 830 -- and if so, test the corresponding constant value, or the name of 831 -- an enumeration literal, which is always a constant. 832 833 if Present (Etype (Op)) and then Is_Entity_Name (Op) then 834 declare 835 E : constant Entity_Id := Entity (Op); 836 V : Node_Id; 837 838 begin 839 -- Never known at compile time if it is a packed array value. 840 -- We might want to try to evaluate these at compile time one 841 -- day, but we do not make that attempt now. 842 843 if Is_Packed_Array_Type (Etype (Op)) then 844 return False; 845 end if; 846 847 if Ekind (E) = E_Enumeration_Literal then 848 return True; 849 850 elsif Ekind (E) = E_Constant then 851 V := Constant_Value (E); 852 return Present (V) and then Compile_Time_Known_Value (V); 853 end if; 854 end; 855 856 -- We have a value, see if it is compile time known 857 858 else 859 -- Integer literals are worth storing in the cache 860 861 if K = N_Integer_Literal then 862 CV_Ent.N := Op; 863 CV_Ent.V := Intval (Op); 864 return True; 865 866 -- Other literals and NULL are known at compile time 867 868 elsif 869 K = N_Character_Literal 870 or else 871 K = N_Real_Literal 872 or else 873 K = N_String_Literal 874 or else 875 K = N_Null 876 then 877 return True; 878 879 -- Any reference to Null_Parameter is known at compile time. No 880 -- other attribute references (that have not already been folded) 881 -- are known at compile time. 882 883 elsif K = N_Attribute_Reference then 884 return Attribute_Name (Op) = Name_Null_Parameter; 885 end if; 886 end if; 887 888 -- If we fall through, not known at compile time 889 890 return False; 891 892 -- If we get an exception while trying to do this test, then some error 893 -- has occurred, and we simply say that the value is not known after all 894 895 exception 896 when others => 897 return False; 898 end Compile_Time_Known_Value; 899 900 -------------------------------------- 901 -- Compile_Time_Known_Value_Or_Aggr -- 902 -------------------------------------- 903 904 function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is 905 begin 906 -- If we have an entity name, then see if it is the name of a constant 907 -- and if so, test the corresponding constant value, or the name of 908 -- an enumeration literal, which is always a constant. 909 910 if Is_Entity_Name (Op) then 911 declare 912 E : constant Entity_Id := Entity (Op); 913 V : Node_Id; 914 915 begin 916 if Ekind (E) = E_Enumeration_Literal then 917 return True; 918 919 elsif Ekind (E) /= E_Constant then 920 return False; 921 922 else 923 V := Constant_Value (E); 924 return Present (V) 925 and then Compile_Time_Known_Value_Or_Aggr (V); 926 end if; 927 end; 928 929 -- We have a value, see if it is compile time known 930 931 else 932 if Compile_Time_Known_Value (Op) then 933 return True; 934 935 elsif Nkind (Op) = N_Aggregate then 936 937 if Present (Expressions (Op)) then 938 declare 939 Expr : Node_Id; 940 941 begin 942 Expr := First (Expressions (Op)); 943 while Present (Expr) loop 944 if not Compile_Time_Known_Value_Or_Aggr (Expr) then 945 return False; 946 end if; 947 948 Next (Expr); 949 end loop; 950 end; 951 end if; 952 953 if Present (Component_Associations (Op)) then 954 declare 955 Cass : Node_Id; 956 957 begin 958 Cass := First (Component_Associations (Op)); 959 while Present (Cass) loop 960 if not 961 Compile_Time_Known_Value_Or_Aggr (Expression (Cass)) 962 then 963 return False; 964 end if; 965 966 Next (Cass); 967 end loop; 968 end; 969 end if; 970 971 return True; 972 973 -- All other types of values are not known at compile time 974 975 else 976 return False; 977 end if; 978 979 end if; 980 end Compile_Time_Known_Value_Or_Aggr; 981 982 ----------------- 983 -- Eval_Actual -- 984 ----------------- 985 986 -- This is only called for actuals of functions that are not predefined 987 -- operators (which have already been rewritten as operators at this 988 -- stage), so the call can never be folded, and all that needs doing for 989 -- the actual is to do the check for a non-static context. 990 991 procedure Eval_Actual (N : Node_Id) is 992 begin 993 Check_Non_Static_Context (N); 994 end Eval_Actual; 995 996 -------------------- 997 -- Eval_Allocator -- 998 -------------------- 999 1000 -- Allocators are never static, so all we have to do is to do the 1001 -- check for a non-static context if an expression is present. 1002 1003 procedure Eval_Allocator (N : Node_Id) is 1004 Expr : constant Node_Id := Expression (N); 1005 1006 begin 1007 if Nkind (Expr) = N_Qualified_Expression then 1008 Check_Non_Static_Context (Expression (Expr)); 1009 end if; 1010 end Eval_Allocator; 1011 1012 ------------------------ 1013 -- Eval_Arithmetic_Op -- 1014 ------------------------ 1015 1016 -- Arithmetic operations are static functions, so the result is static 1017 -- if both operands are static (RM 4.9(7), 4.9(20)). 1018 1019 procedure Eval_Arithmetic_Op (N : Node_Id) is 1020 Left : constant Node_Id := Left_Opnd (N); 1021 Right : constant Node_Id := Right_Opnd (N); 1022 Ltype : constant Entity_Id := Etype (Left); 1023 Rtype : constant Entity_Id := Etype (Right); 1024 Stat : Boolean; 1025 Fold : Boolean; 1026 1027 begin 1028 -- If not foldable we are done 1029 1030 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); 1031 1032 if not Fold then 1033 return; 1034 end if; 1035 1036 -- Fold for cases where both operands are of integer type 1037 1038 if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then 1039 declare 1040 Left_Int : constant Uint := Expr_Value (Left); 1041 Right_Int : constant Uint := Expr_Value (Right); 1042 Result : Uint; 1043 1044 begin 1045 case Nkind (N) is 1046 1047 when N_Op_Add => 1048 Result := Left_Int + Right_Int; 1049 1050 when N_Op_Subtract => 1051 Result := Left_Int - Right_Int; 1052 1053 when N_Op_Multiply => 1054 if OK_Bits 1055 (N, UI_From_Int 1056 (Num_Bits (Left_Int) + Num_Bits (Right_Int))) 1057 then 1058 Result := Left_Int * Right_Int; 1059 else 1060 Result := Left_Int; 1061 end if; 1062 1063 when N_Op_Divide => 1064 1065 -- The exception Constraint_Error is raised by integer 1066 -- division, rem and mod if the right operand is zero. 1067 1068 if Right_Int = 0 then 1069 Apply_Compile_Time_Constraint_Error 1070 (N, "division by zero", 1071 CE_Divide_By_Zero, 1072 Warn => not Stat); 1073 return; 1074 1075 else 1076 Result := Left_Int / Right_Int; 1077 end if; 1078 1079 when N_Op_Mod => 1080 1081 -- The exception Constraint_Error is raised by integer 1082 -- division, rem and mod if the right operand is zero. 1083 1084 if Right_Int = 0 then 1085 Apply_Compile_Time_Constraint_Error 1086 (N, "mod with zero divisor", 1087 CE_Divide_By_Zero, 1088 Warn => not Stat); 1089 return; 1090 else 1091 Result := Left_Int mod Right_Int; 1092 end if; 1093 1094 when N_Op_Rem => 1095 1096 -- The exception Constraint_Error is raised by integer 1097 -- division, rem and mod if the right operand is zero. 1098 1099 if Right_Int = 0 then 1100 Apply_Compile_Time_Constraint_Error 1101 (N, "rem with zero divisor", 1102 CE_Divide_By_Zero, 1103 Warn => not Stat); 1104 return; 1105 1106 else 1107 Result := Left_Int rem Right_Int; 1108 end if; 1109 1110 when others => 1111 raise Program_Error; 1112 end case; 1113 1114 -- Adjust the result by the modulus if the type is a modular type 1115 1116 if Is_Modular_Integer_Type (Ltype) then 1117 Result := Result mod Modulus (Ltype); 1118 end if; 1119 1120 Fold_Uint (N, Result, Stat); 1121 end; 1122 1123 -- Cases where at least one operand is a real. We handle the cases 1124 -- of both reals, or mixed/real integer cases (the latter happen 1125 -- only for divide and multiply, and the result is always real). 1126 1127 elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then 1128 declare 1129 Left_Real : Ureal; 1130 Right_Real : Ureal; 1131 Result : Ureal; 1132 1133 begin 1134 if Is_Real_Type (Ltype) then 1135 Left_Real := Expr_Value_R (Left); 1136 else 1137 Left_Real := UR_From_Uint (Expr_Value (Left)); 1138 end if; 1139 1140 if Is_Real_Type (Rtype) then 1141 Right_Real := Expr_Value_R (Right); 1142 else 1143 Right_Real := UR_From_Uint (Expr_Value (Right)); 1144 end if; 1145 1146 if Nkind (N) = N_Op_Add then 1147 Result := Left_Real + Right_Real; 1148 1149 elsif Nkind (N) = N_Op_Subtract then 1150 Result := Left_Real - Right_Real; 1151 1152 elsif Nkind (N) = N_Op_Multiply then 1153 Result := Left_Real * Right_Real; 1154 1155 else pragma Assert (Nkind (N) = N_Op_Divide); 1156 if UR_Is_Zero (Right_Real) then 1157 Apply_Compile_Time_Constraint_Error 1158 (N, "division by zero", CE_Divide_By_Zero); 1159 return; 1160 end if; 1161 1162 Result := Left_Real / Right_Real; 1163 end if; 1164 1165 Fold_Ureal (N, Result, Stat); 1166 end; 1167 end if; 1168 end Eval_Arithmetic_Op; 1169 1170 ---------------------------- 1171 -- Eval_Character_Literal -- 1172 ---------------------------- 1173 1174 -- Nothing to be done! 1175 1176 procedure Eval_Character_Literal (N : Node_Id) is 1177 pragma Warnings (Off, N); 1178 1179 begin 1180 null; 1181 end Eval_Character_Literal; 1182 1183 ------------------------ 1184 -- Eval_Concatenation -- 1185 ------------------------ 1186 1187 -- Concatenation is a static function, so the result is static if 1188 -- both operands are static (RM 4.9(7), 4.9(21)). 1189 1190 procedure Eval_Concatenation (N : Node_Id) is 1191 Left : constant Node_Id := Left_Opnd (N); 1192 Right : constant Node_Id := Right_Opnd (N); 1193 C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N))); 1194 Stat : Boolean; 1195 Fold : Boolean; 1196 1197 begin 1198 -- Concatenation is never static in Ada 83, so if Ada 83 1199 -- check operand non-static context 1200 1201 if Ada_83 1202 and then Comes_From_Source (N) 1203 then 1204 Check_Non_Static_Context (Left); 1205 Check_Non_Static_Context (Right); 1206 return; 1207 end if; 1208 1209 -- If not foldable we are done. In principle concatenation that yields 1210 -- any string type is static (i.e. an array type of character types). 1211 -- However, character types can include enumeration literals, and 1212 -- concatenation in that case cannot be described by a literal, so we 1213 -- only consider the operation static if the result is an array of 1214 -- (a descendant of) a predefined character type. 1215 1216 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); 1217 1218 if (C_Typ = Standard_Character 1219 or else C_Typ = Standard_Wide_Character) 1220 and then Fold 1221 then 1222 null; 1223 else 1224 Set_Is_Static_Expression (N, False); 1225 return; 1226 end if; 1227 1228 -- Compile time string concatenation. 1229 1230 -- ??? Note that operands that are aggregates can be marked as 1231 -- static, so we should attempt at a later stage to fold 1232 -- concatenations with such aggregates. 1233 1234 declare 1235 Left_Str : constant Node_Id := Get_String_Val (Left); 1236 Left_Len : Nat; 1237 Right_Str : constant Node_Id := Get_String_Val (Right); 1238 1239 begin 1240 -- Establish new string literal, and store left operand. We make 1241 -- sure to use the special Start_String that takes an operand if 1242 -- the left operand is a string literal. Since this is optimized 1243 -- in the case where that is the most recently created string 1244 -- literal, we ensure efficient time/space behavior for the 1245 -- case of a concatenation of a series of string literals. 1246 1247 if Nkind (Left_Str) = N_String_Literal then 1248 Left_Len := String_Length (Strval (Left_Str)); 1249 Start_String (Strval (Left_Str)); 1250 else 1251 Start_String; 1252 Store_String_Char (Char_Literal_Value (Left_Str)); 1253 Left_Len := 1; 1254 end if; 1255 1256 -- Now append the characters of the right operand 1257 1258 if Nkind (Right_Str) = N_String_Literal then 1259 declare 1260 S : constant String_Id := Strval (Right_Str); 1261 1262 begin 1263 for J in 1 .. String_Length (S) loop 1264 Store_String_Char (Get_String_Char (S, J)); 1265 end loop; 1266 end; 1267 else 1268 Store_String_Char (Char_Literal_Value (Right_Str)); 1269 end if; 1270 1271 Set_Is_Static_Expression (N, Stat); 1272 1273 if Stat then 1274 1275 -- If left operand is the empty string, the result is the 1276 -- right operand, including its bounds if anomalous. 1277 1278 if Left_Len = 0 1279 and then Is_Array_Type (Etype (Right)) 1280 and then Etype (Right) /= Any_String 1281 then 1282 Set_Etype (N, Etype (Right)); 1283 end if; 1284 1285 Fold_Str (N, End_String, True); 1286 end if; 1287 end; 1288 end Eval_Concatenation; 1289 1290 --------------------------------- 1291 -- Eval_Conditional_Expression -- 1292 --------------------------------- 1293 1294 -- This GNAT internal construct can never be statically folded, so the 1295 -- only required processing is to do the check for non-static context 1296 -- for the two expression operands. 1297 1298 procedure Eval_Conditional_Expression (N : Node_Id) is 1299 Condition : constant Node_Id := First (Expressions (N)); 1300 Then_Expr : constant Node_Id := Next (Condition); 1301 Else_Expr : constant Node_Id := Next (Then_Expr); 1302 1303 begin 1304 Check_Non_Static_Context (Then_Expr); 1305 Check_Non_Static_Context (Else_Expr); 1306 end Eval_Conditional_Expression; 1307 1308 ---------------------- 1309 -- Eval_Entity_Name -- 1310 ---------------------- 1311 1312 -- This procedure is used for identifiers and expanded names other than 1313 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are 1314 -- static if they denote a static constant (RM 4.9(6)) or if the name 1315 -- denotes an enumeration literal (RM 4.9(22)). 1316 1317 procedure Eval_Entity_Name (N : Node_Id) is 1318 Def_Id : constant Entity_Id := Entity (N); 1319 Val : Node_Id; 1320 1321 begin 1322 -- Enumeration literals are always considered to be constants 1323 -- and cannot raise constraint error (RM 4.9(22)). 1324 1325 if Ekind (Def_Id) = E_Enumeration_Literal then 1326 Set_Is_Static_Expression (N); 1327 return; 1328 1329 -- A name is static if it denotes a static constant (RM 4.9(5)), and 1330 -- we also copy Raise_Constraint_Error. Notice that even if non-static, 1331 -- it does not violate 10.2.1(8) here, since this is not a variable. 1332 1333 elsif Ekind (Def_Id) = E_Constant then 1334 1335 -- Deferred constants must always be treated as nonstatic 1336 -- outside the scope of their full view. 1337 1338 if Present (Full_View (Def_Id)) 1339 and then not In_Open_Scopes (Scope (Def_Id)) 1340 then 1341 Val := Empty; 1342 else 1343 Val := Constant_Value (Def_Id); 1344 end if; 1345 1346 if Present (Val) then 1347 Set_Is_Static_Expression 1348 (N, Is_Static_Expression (Val) 1349 and then Is_Static_Subtype (Etype (Def_Id))); 1350 Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val)); 1351 1352 if not Is_Static_Expression (N) 1353 and then not Is_Generic_Type (Etype (N)) 1354 then 1355 Validate_Static_Object_Name (N); 1356 end if; 1357 1358 return; 1359 end if; 1360 end if; 1361 1362 -- Fall through if the name is not static. 1363 1364 Validate_Static_Object_Name (N); 1365 end Eval_Entity_Name; 1366 1367 ---------------------------- 1368 -- Eval_Indexed_Component -- 1369 ---------------------------- 1370 1371 -- Indexed components are never static, so we need to perform the check 1372 -- for non-static context on the index values. Then, we check if the 1373 -- value can be obtained at compile time, even though it is non-static. 1374 1375 procedure Eval_Indexed_Component (N : Node_Id) is 1376 Expr : Node_Id; 1377 1378 begin 1379 -- Check for non-static context on index values 1380 1381 Expr := First (Expressions (N)); 1382 while Present (Expr) loop 1383 Check_Non_Static_Context (Expr); 1384 Next (Expr); 1385 end loop; 1386 1387 -- If the indexed component appears in an object renaming declaration 1388 -- then we do not want to try to evaluate it, since in this case we 1389 -- need the identity of the array element. 1390 1391 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then 1392 return; 1393 1394 -- Similarly if the indexed component appears as the prefix of an 1395 -- attribute we don't want to evaluate it, because at least for 1396 -- some cases of attributes we need the identify (e.g. Access, Size) 1397 1398 elsif Nkind (Parent (N)) = N_Attribute_Reference then 1399 return; 1400 end if; 1401 1402 -- Note: there are other cases, such as the left side of an assignment, 1403 -- or an OUT parameter for a call, where the replacement results in the 1404 -- illegal use of a constant, But these cases are illegal in the first 1405 -- place, so the replacement, though silly, is harmless. 1406 1407 -- Now see if this is a constant array reference 1408 1409 if List_Length (Expressions (N)) = 1 1410 and then Is_Entity_Name (Prefix (N)) 1411 and then Ekind (Entity (Prefix (N))) = E_Constant 1412 and then Present (Constant_Value (Entity (Prefix (N)))) 1413 then 1414 declare 1415 Loc : constant Source_Ptr := Sloc (N); 1416 Arr : constant Node_Id := Constant_Value (Entity (Prefix (N))); 1417 Sub : constant Node_Id := First (Expressions (N)); 1418 1419 Atyp : Entity_Id; 1420 -- Type of array 1421 1422 Lin : Nat; 1423 -- Linear one's origin subscript value for array reference 1424 1425 Lbd : Node_Id; 1426 -- Lower bound of the first array index 1427 1428 Elm : Node_Id; 1429 -- Value from constant array 1430 1431 begin 1432 Atyp := Etype (Arr); 1433 1434 if Is_Access_Type (Atyp) then 1435 Atyp := Designated_Type (Atyp); 1436 end if; 1437 1438 -- If we have an array type (we should have but perhaps there 1439 -- are error cases where this is not the case), then see if we 1440 -- can do a constant evaluation of the array reference. 1441 1442 if Is_Array_Type (Atyp) then 1443 if Ekind (Atyp) = E_String_Literal_Subtype then 1444 Lbd := String_Literal_Low_Bound (Atyp); 1445 else 1446 Lbd := Type_Low_Bound (Etype (First_Index (Atyp))); 1447 end if; 1448 1449 if Compile_Time_Known_Value (Sub) 1450 and then Nkind (Arr) = N_Aggregate 1451 and then Compile_Time_Known_Value (Lbd) 1452 and then Is_Discrete_Type (Component_Type (Atyp)) 1453 then 1454 Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1; 1455 1456 if List_Length (Expressions (Arr)) >= Lin then 1457 Elm := Pick (Expressions (Arr), Lin); 1458 1459 -- If the resulting expression is compile time known, 1460 -- then we can rewrite the indexed component with this 1461 -- value, being sure to mark the result as non-static. 1462 -- We also reset the Sloc, in case this generates an 1463 -- error later on (e.g. 136'Access). 1464 1465 if Compile_Time_Known_Value (Elm) then 1466 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm)); 1467 Set_Is_Static_Expression (N, False); 1468 Set_Sloc (N, Loc); 1469 end if; 1470 end if; 1471 end if; 1472 end if; 1473 end; 1474 end if; 1475 end Eval_Indexed_Component; 1476 1477 -------------------------- 1478 -- Eval_Integer_Literal -- 1479 -------------------------- 1480 1481 -- Numeric literals are static (RM 4.9(1)), and have already been marked 1482 -- as static by the analyzer. The reason we did it that early is to allow 1483 -- the possibility of turning off the Is_Static_Expression flag after 1484 -- analysis, but before resolution, when integer literals are generated 1485 -- in the expander that do not correspond to static expressions. 1486 1487 procedure Eval_Integer_Literal (N : Node_Id) is 1488 T : constant Entity_Id := Etype (N); 1489 1490 begin 1491 -- If the literal appears in a non-expression context, then it is 1492 -- certainly appearing in a non-static context, so check it. This 1493 -- is actually a redundant check, since Check_Non_Static_Context 1494 -- would check it, but it seems worth while avoiding the call. 1495 1496 if Nkind (Parent (N)) not in N_Subexpr then 1497 Check_Non_Static_Context (N); 1498 end if; 1499 1500 -- Modular integer literals must be in their base range 1501 1502 if Is_Modular_Integer_Type (T) 1503 and then Is_Out_Of_Range (N, Base_Type (T)) 1504 then 1505 Out_Of_Range (N); 1506 end if; 1507 end Eval_Integer_Literal; 1508 1509 --------------------- 1510 -- Eval_Logical_Op -- 1511 --------------------- 1512 1513 -- Logical operations are static functions, so the result is potentially 1514 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)). 1515 1516 procedure Eval_Logical_Op (N : Node_Id) is 1517 Left : constant Node_Id := Left_Opnd (N); 1518 Right : constant Node_Id := Right_Opnd (N); 1519 Stat : Boolean; 1520 Fold : Boolean; 1521 1522 begin 1523 -- If not foldable we are done 1524 1525 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); 1526 1527 if not Fold then 1528 return; 1529 end if; 1530 1531 -- Compile time evaluation of logical operation 1532 1533 declare 1534 Left_Int : constant Uint := Expr_Value (Left); 1535 Right_Int : constant Uint := Expr_Value (Right); 1536 1537 begin 1538 if Is_Modular_Integer_Type (Etype (N)) then 1539 declare 1540 Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); 1541 Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1); 1542 1543 begin 1544 To_Bits (Left_Int, Left_Bits); 1545 To_Bits (Right_Int, Right_Bits); 1546 1547 -- Note: should really be able to use array ops instead of 1548 -- these loops, but they weren't working at the time ??? 1549 1550 if Nkind (N) = N_Op_And then 1551 for J in Left_Bits'Range loop 1552 Left_Bits (J) := Left_Bits (J) and Right_Bits (J); 1553 end loop; 1554 1555 elsif Nkind (N) = N_Op_Or then 1556 for J in Left_Bits'Range loop 1557 Left_Bits (J) := Left_Bits (J) or Right_Bits (J); 1558 end loop; 1559 1560 else 1561 pragma Assert (Nkind (N) = N_Op_Xor); 1562 1563 for J in Left_Bits'Range loop 1564 Left_Bits (J) := Left_Bits (J) xor Right_Bits (J); 1565 end loop; 1566 end if; 1567 1568 Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat); 1569 end; 1570 1571 else 1572 pragma Assert (Is_Boolean_Type (Etype (N))); 1573 1574 if Nkind (N) = N_Op_And then 1575 Fold_Uint (N, 1576 Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat); 1577 1578 elsif Nkind (N) = N_Op_Or then 1579 Fold_Uint (N, 1580 Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat); 1581 1582 else 1583 pragma Assert (Nkind (N) = N_Op_Xor); 1584 Fold_Uint (N, 1585 Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat); 1586 end if; 1587 end if; 1588 end; 1589 end Eval_Logical_Op; 1590 1591 ------------------------ 1592 -- Eval_Membership_Op -- 1593 ------------------------ 1594 1595 -- A membership test is potentially static if the expression is static, 1596 -- and the range is a potentially static range, or is a subtype mark 1597 -- denoting a static subtype (RM 4.9(12)). 1598 1599 procedure Eval_Membership_Op (N : Node_Id) is 1600 Left : constant Node_Id := Left_Opnd (N); 1601 Right : constant Node_Id := Right_Opnd (N); 1602 Def_Id : Entity_Id; 1603 Lo : Node_Id; 1604 Hi : Node_Id; 1605 Result : Boolean; 1606 Stat : Boolean; 1607 Fold : Boolean; 1608 1609 begin 1610 -- Ignore if error in either operand, except to make sure that 1611 -- Any_Type is properly propagated to avoid junk cascaded errors. 1612 1613 if Etype (Left) = Any_Type 1614 or else Etype (Right) = Any_Type 1615 then 1616 Set_Etype (N, Any_Type); 1617 return; 1618 end if; 1619 1620 -- Case of right operand is a subtype name 1621 1622 if Is_Entity_Name (Right) then 1623 Def_Id := Entity (Right); 1624 1625 if (Is_Scalar_Type (Def_Id) or else Is_String_Type (Def_Id)) 1626 and then Is_OK_Static_Subtype (Def_Id) 1627 then 1628 Test_Expression_Is_Foldable (N, Left, Stat, Fold); 1629 1630 if not Fold or else not Stat then 1631 return; 1632 end if; 1633 else 1634 Check_Non_Static_Context (Left); 1635 return; 1636 end if; 1637 1638 -- For string membership tests we will check the length 1639 -- further below. 1640 1641 if not Is_String_Type (Def_Id) then 1642 Lo := Type_Low_Bound (Def_Id); 1643 Hi := Type_High_Bound (Def_Id); 1644 1645 else 1646 Lo := Empty; 1647 Hi := Empty; 1648 end if; 1649 1650 -- Case of right operand is a range 1651 1652 else 1653 if Is_Static_Range (Right) then 1654 Test_Expression_Is_Foldable (N, Left, Stat, Fold); 1655 1656 if not Fold or else not Stat then 1657 return; 1658 1659 -- If one bound of range raises CE, then don't try to fold 1660 1661 elsif not Is_OK_Static_Range (Right) then 1662 Check_Non_Static_Context (Left); 1663 return; 1664 end if; 1665 1666 else 1667 Check_Non_Static_Context (Left); 1668 return; 1669 end if; 1670 1671 -- Here we know range is an OK static range 1672 1673 Lo := Low_Bound (Right); 1674 Hi := High_Bound (Right); 1675 end if; 1676 1677 -- For strings we check that the length of the string expression is 1678 -- compatible with the string subtype if the subtype is constrained, 1679 -- or if unconstrained then the test is always true. 1680 1681 if Is_String_Type (Etype (Right)) then 1682 if not Is_Constrained (Etype (Right)) then 1683 Result := True; 1684 1685 else 1686 declare 1687 Typlen : constant Uint := String_Type_Len (Etype (Right)); 1688 Strlen : constant Uint := 1689 UI_From_Int (String_Length (Strval (Get_String_Val (Left)))); 1690 begin 1691 Result := (Typlen = Strlen); 1692 end; 1693 end if; 1694 1695 -- Fold the membership test. We know we have a static range and Lo 1696 -- and Hi are set to the expressions for the end points of this range. 1697 1698 elsif Is_Real_Type (Etype (Right)) then 1699 declare 1700 Leftval : constant Ureal := Expr_Value_R (Left); 1701 1702 begin 1703 Result := Expr_Value_R (Lo) <= Leftval 1704 and then Leftval <= Expr_Value_R (Hi); 1705 end; 1706 1707 else 1708 declare 1709 Leftval : constant Uint := Expr_Value (Left); 1710 1711 begin 1712 Result := Expr_Value (Lo) <= Leftval 1713 and then Leftval <= Expr_Value (Hi); 1714 end; 1715 end if; 1716 1717 if Nkind (N) = N_Not_In then 1718 Result := not Result; 1719 end if; 1720 1721 Fold_Uint (N, Test (Result), True); 1722 Warn_On_Known_Condition (N); 1723 end Eval_Membership_Op; 1724 1725 ------------------------ 1726 -- Eval_Named_Integer -- 1727 ------------------------ 1728 1729 procedure Eval_Named_Integer (N : Node_Id) is 1730 begin 1731 Fold_Uint (N, 1732 Expr_Value (Expression (Declaration_Node (Entity (N)))), True); 1733 end Eval_Named_Integer; 1734 1735 --------------------- 1736 -- Eval_Named_Real -- 1737 --------------------- 1738 1739 procedure Eval_Named_Real (N : Node_Id) is 1740 begin 1741 Fold_Ureal (N, 1742 Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True); 1743 end Eval_Named_Real; 1744 1745 ------------------- 1746 -- Eval_Op_Expon -- 1747 ------------------- 1748 1749 -- Exponentiation is a static functions, so the result is potentially 1750 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)). 1751 1752 procedure Eval_Op_Expon (N : Node_Id) is 1753 Left : constant Node_Id := Left_Opnd (N); 1754 Right : constant Node_Id := Right_Opnd (N); 1755 Stat : Boolean; 1756 Fold : Boolean; 1757 1758 begin 1759 -- If not foldable we are done 1760 1761 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); 1762 1763 if not Fold then 1764 return; 1765 end if; 1766 1767 -- Fold exponentiation operation 1768 1769 declare 1770 Right_Int : constant Uint := Expr_Value (Right); 1771 1772 begin 1773 -- Integer case 1774 1775 if Is_Integer_Type (Etype (Left)) then 1776 declare 1777 Left_Int : constant Uint := Expr_Value (Left); 1778 Result : Uint; 1779 1780 begin 1781 -- Exponentiation of an integer raises the exception 1782 -- Constraint_Error for a negative exponent (RM 4.5.6) 1783 1784 if Right_Int < 0 then 1785 Apply_Compile_Time_Constraint_Error 1786 (N, "integer exponent negative", 1787 CE_Range_Check_Failed, 1788 Warn => not Stat); 1789 return; 1790 1791 else 1792 if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then 1793 Result := Left_Int ** Right_Int; 1794 else 1795 Result := Left_Int; 1796 end if; 1797 1798 if Is_Modular_Integer_Type (Etype (N)) then 1799 Result := Result mod Modulus (Etype (N)); 1800 end if; 1801 1802 Fold_Uint (N, Result, Stat); 1803 end if; 1804 end; 1805 1806 -- Real case 1807 1808 else 1809 declare 1810 Left_Real : constant Ureal := Expr_Value_R (Left); 1811 1812 begin 1813 -- Cannot have a zero base with a negative exponent 1814 1815 if UR_Is_Zero (Left_Real) then 1816 1817 if Right_Int < 0 then 1818 Apply_Compile_Time_Constraint_Error 1819 (N, "zero ** negative integer", 1820 CE_Range_Check_Failed, 1821 Warn => not Stat); 1822 return; 1823 else 1824 Fold_Ureal (N, Ureal_0, Stat); 1825 end if; 1826 1827 else 1828 Fold_Ureal (N, Left_Real ** Right_Int, Stat); 1829 end if; 1830 end; 1831 end if; 1832 end; 1833 end Eval_Op_Expon; 1834 1835 ----------------- 1836 -- Eval_Op_Not -- 1837 ----------------- 1838 1839 -- The not operation is a static functions, so the result is potentially 1840 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)). 1841 1842 procedure Eval_Op_Not (N : Node_Id) is 1843 Right : constant Node_Id := Right_Opnd (N); 1844 Stat : Boolean; 1845 Fold : Boolean; 1846 1847 begin 1848 -- If not foldable we are done 1849 1850 Test_Expression_Is_Foldable (N, Right, Stat, Fold); 1851 1852 if not Fold then 1853 return; 1854 end if; 1855 1856 -- Fold not operation 1857 1858 declare 1859 Rint : constant Uint := Expr_Value (Right); 1860 Typ : constant Entity_Id := Etype (N); 1861 1862 begin 1863 -- Negation is equivalent to subtracting from the modulus minus 1864 -- one. For a binary modulus this is equivalent to the ones- 1865 -- component of the original value. For non-binary modulus this 1866 -- is an arbitrary but consistent definition. 1867 1868 if Is_Modular_Integer_Type (Typ) then 1869 Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat); 1870 1871 else 1872 pragma Assert (Is_Boolean_Type (Typ)); 1873 Fold_Uint (N, Test (not Is_True (Rint)), Stat); 1874 end if; 1875 1876 Set_Is_Static_Expression (N, Stat); 1877 end; 1878 end Eval_Op_Not; 1879 1880 ------------------------------- 1881 -- Eval_Qualified_Expression -- 1882 ------------------------------- 1883 1884 -- A qualified expression is potentially static if its subtype mark denotes 1885 -- a static subtype and its expression is potentially static (RM 4.9 (11)). 1886 1887 procedure Eval_Qualified_Expression (N : Node_Id) is 1888 Operand : constant Node_Id := Expression (N); 1889 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N)); 1890 1891 Stat : Boolean; 1892 Fold : Boolean; 1893 Hex : Boolean; 1894 1895 begin 1896 -- Can only fold if target is string or scalar and subtype is static 1897 -- Also, do not fold if our parent is an allocator (this is because 1898 -- the qualified expression is really part of the syntactic structure 1899 -- of an allocator, and we do not want to end up with something that 1900 -- corresponds to "new 1" where the 1 is the result of folding a 1901 -- qualified expression). 1902 1903 if not Is_Static_Subtype (Target_Type) 1904 or else Nkind (Parent (N)) = N_Allocator 1905 then 1906 Check_Non_Static_Context (Operand); 1907 return; 1908 end if; 1909 1910 -- If not foldable we are done 1911 1912 Test_Expression_Is_Foldable (N, Operand, Stat, Fold); 1913 1914 if not Fold then 1915 return; 1916 1917 -- Don't try fold if target type has constraint error bounds 1918 1919 elsif not Is_OK_Static_Subtype (Target_Type) then 1920 Set_Raises_Constraint_Error (N); 1921 return; 1922 end if; 1923 1924 -- Here we will fold, save Print_In_Hex indication 1925 1926 Hex := Nkind (Operand) = N_Integer_Literal 1927 and then Print_In_Hex (Operand); 1928 1929 -- Fold the result of qualification 1930 1931 if Is_Discrete_Type (Target_Type) then 1932 Fold_Uint (N, Expr_Value (Operand), Stat); 1933 1934 -- Preserve Print_In_Hex indication 1935 1936 if Hex and then Nkind (N) = N_Integer_Literal then 1937 Set_Print_In_Hex (N); 1938 end if; 1939 1940 elsif Is_Real_Type (Target_Type) then 1941 Fold_Ureal (N, Expr_Value_R (Operand), Stat); 1942 1943 else 1944 Fold_Str (N, Strval (Get_String_Val (Operand)), Stat); 1945 1946 if not Stat then 1947 Set_Is_Static_Expression (N, False); 1948 else 1949 Check_String_Literal_Length (N, Target_Type); 1950 end if; 1951 1952 return; 1953 end if; 1954 1955 -- The expression may be foldable but not static 1956 1957 Set_Is_Static_Expression (N, Stat); 1958 1959 if Is_Out_Of_Range (N, Etype (N)) then 1960 Out_Of_Range (N); 1961 end if; 1962 end Eval_Qualified_Expression; 1963 1964 ----------------------- 1965 -- Eval_Real_Literal -- 1966 ----------------------- 1967 1968 -- Numeric literals are static (RM 4.9(1)), and have already been marked 1969 -- as static by the analyzer. The reason we did it that early is to allow 1970 -- the possibility of turning off the Is_Static_Expression flag after 1971 -- analysis, but before resolution, when integer literals are generated 1972 -- in the expander that do not correspond to static expressions. 1973 1974 procedure Eval_Real_Literal (N : Node_Id) is 1975 begin 1976 -- If the literal appears in a non-expression context, then it is 1977 -- certainly appearing in a non-static context, so check it. 1978 1979 if Nkind (Parent (N)) not in N_Subexpr then 1980 Check_Non_Static_Context (N); 1981 end if; 1982 1983 end Eval_Real_Literal; 1984 1985 ------------------------ 1986 -- Eval_Relational_Op -- 1987 ------------------------ 1988 1989 -- Relational operations are static functions, so the result is static 1990 -- if both operands are static (RM 4.9(7), 4.9(20)). 1991 1992 procedure Eval_Relational_Op (N : Node_Id) is 1993 Left : constant Node_Id := Left_Opnd (N); 1994 Right : constant Node_Id := Right_Opnd (N); 1995 Typ : constant Entity_Id := Etype (Left); 1996 Result : Boolean; 1997 Stat : Boolean; 1998 Fold : Boolean; 1999 2000 begin 2001 -- One special case to deal with first. If we can tell that 2002 -- the result will be false because the lengths of one or 2003 -- more index subtypes are compile time known and different, 2004 -- then we can replace the entire result by False. We only 2005 -- do this for one dimensional arrays, because the case of 2006 -- multi-dimensional arrays is rare and too much trouble! 2007 2008 if Is_Array_Type (Typ) 2009 and then Number_Dimensions (Typ) = 1 2010 and then (Nkind (N) = N_Op_Eq 2011 or else Nkind (N) = N_Op_Ne) 2012 then 2013 if Raises_Constraint_Error (Left) 2014 or else Raises_Constraint_Error (Right) 2015 then 2016 return; 2017 end if; 2018 2019 declare 2020 procedure Get_Static_Length (Op : Node_Id; Len : out Uint); 2021 -- If Op is an expression for a constrained array with a 2022 -- known at compile time length, then Len is set to this 2023 -- (non-negative length). Otherwise Len is set to minus 1. 2024 2025 ----------------------- 2026 -- Get_Static_Length -- 2027 ----------------------- 2028 2029 procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is 2030 T : Entity_Id; 2031 2032 begin 2033 if Nkind (Op) = N_String_Literal then 2034 Len := UI_From_Int (String_Length (Strval (Op))); 2035 2036 elsif not Is_Constrained (Etype (Op)) then 2037 Len := Uint_Minus_1; 2038 2039 else 2040 T := Etype (First_Index (Etype (Op))); 2041 2042 if Is_Discrete_Type (T) 2043 and then 2044 Compile_Time_Known_Value (Type_Low_Bound (T)) 2045 and then 2046 Compile_Time_Known_Value (Type_High_Bound (T)) 2047 then 2048 Len := UI_Max (Uint_0, 2049 Expr_Value (Type_High_Bound (T)) - 2050 Expr_Value (Type_Low_Bound (T)) + 1); 2051 else 2052 Len := Uint_Minus_1; 2053 end if; 2054 end if; 2055 end Get_Static_Length; 2056 2057 Len_L : Uint; 2058 Len_R : Uint; 2059 2060 begin 2061 Get_Static_Length (Left, Len_L); 2062 Get_Static_Length (Right, Len_R); 2063 2064 if Len_L /= Uint_Minus_1 2065 and then Len_R /= Uint_Minus_1 2066 and then Len_L /= Len_R 2067 then 2068 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False); 2069 Warn_On_Known_Condition (N); 2070 return; 2071 end if; 2072 end; 2073 end if; 2074 2075 -- Can only fold if type is scalar (don't fold string ops) 2076 2077 if not Is_Scalar_Type (Typ) then 2078 Check_Non_Static_Context (Left); 2079 Check_Non_Static_Context (Right); 2080 return; 2081 end if; 2082 2083 -- If not foldable we are done 2084 2085 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); 2086 2087 if not Fold then 2088 return; 2089 end if; 2090 2091 -- Integer and Enumeration (discrete) type cases 2092 2093 if Is_Discrete_Type (Typ) then 2094 declare 2095 Left_Int : constant Uint := Expr_Value (Left); 2096 Right_Int : constant Uint := Expr_Value (Right); 2097 2098 begin 2099 case Nkind (N) is 2100 when N_Op_Eq => Result := Left_Int = Right_Int; 2101 when N_Op_Ne => Result := Left_Int /= Right_Int; 2102 when N_Op_Lt => Result := Left_Int < Right_Int; 2103 when N_Op_Le => Result := Left_Int <= Right_Int; 2104 when N_Op_Gt => Result := Left_Int > Right_Int; 2105 when N_Op_Ge => Result := Left_Int >= Right_Int; 2106 2107 when others => 2108 raise Program_Error; 2109 end case; 2110 2111 Fold_Uint (N, Test (Result), Stat); 2112 end; 2113 2114 -- Real type case 2115 2116 else 2117 pragma Assert (Is_Real_Type (Typ)); 2118 2119 declare 2120 Left_Real : constant Ureal := Expr_Value_R (Left); 2121 Right_Real : constant Ureal := Expr_Value_R (Right); 2122 2123 begin 2124 case Nkind (N) is 2125 when N_Op_Eq => Result := (Left_Real = Right_Real); 2126 when N_Op_Ne => Result := (Left_Real /= Right_Real); 2127 when N_Op_Lt => Result := (Left_Real < Right_Real); 2128 when N_Op_Le => Result := (Left_Real <= Right_Real); 2129 when N_Op_Gt => Result := (Left_Real > Right_Real); 2130 when N_Op_Ge => Result := (Left_Real >= Right_Real); 2131 2132 when others => 2133 raise Program_Error; 2134 end case; 2135 2136 Fold_Uint (N, Test (Result), Stat); 2137 end; 2138 end if; 2139 2140 Warn_On_Known_Condition (N); 2141 end Eval_Relational_Op; 2142 2143 ---------------- 2144 -- Eval_Shift -- 2145 ---------------- 2146 2147 -- Shift operations are intrinsic operations that can never be static, 2148 -- so the only processing required is to perform the required check for 2149 -- a non static context for the two operands. 2150 2151 -- Actually we could do some compile time evaluation here some time ??? 2152 2153 procedure Eval_Shift (N : Node_Id) is 2154 begin 2155 Check_Non_Static_Context (Left_Opnd (N)); 2156 Check_Non_Static_Context (Right_Opnd (N)); 2157 end Eval_Shift; 2158 2159 ------------------------ 2160 -- Eval_Short_Circuit -- 2161 ------------------------ 2162 2163 -- A short circuit operation is potentially static if both operands 2164 -- are potentially static (RM 4.9 (13)) 2165 2166 procedure Eval_Short_Circuit (N : Node_Id) is 2167 Kind : constant Node_Kind := Nkind (N); 2168 Left : constant Node_Id := Left_Opnd (N); 2169 Right : constant Node_Id := Right_Opnd (N); 2170 Left_Int : Uint; 2171 Rstat : constant Boolean := 2172 Is_Static_Expression (Left) 2173 and then Is_Static_Expression (Right); 2174 2175 begin 2176 -- Short circuit operations are never static in Ada 83 2177 2178 if Ada_83 2179 and then Comes_From_Source (N) 2180 then 2181 Check_Non_Static_Context (Left); 2182 Check_Non_Static_Context (Right); 2183 return; 2184 end if; 2185 2186 -- Now look at the operands, we can't quite use the normal call to 2187 -- Test_Expression_Is_Foldable here because short circuit operations 2188 -- are a special case, they can still be foldable, even if the right 2189 -- operand raises constraint error. 2190 2191 -- If either operand is Any_Type, just propagate to result and 2192 -- do not try to fold, this prevents cascaded errors. 2193 2194 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then 2195 Set_Etype (N, Any_Type); 2196 return; 2197 2198 -- If left operand raises constraint error, then replace node N with 2199 -- the raise constraint error node, and we are obviously not foldable. 2200 -- Is_Static_Expression is set from the two operands in the normal way, 2201 -- and we check the right operand if it is in a non-static context. 2202 2203 elsif Raises_Constraint_Error (Left) then 2204 if not Rstat then 2205 Check_Non_Static_Context (Right); 2206 end if; 2207 2208 Rewrite_In_Raise_CE (N, Left); 2209 Set_Is_Static_Expression (N, Rstat); 2210 return; 2211 2212 -- If the result is not static, then we won't in any case fold 2213 2214 elsif not Rstat then 2215 Check_Non_Static_Context (Left); 2216 Check_Non_Static_Context (Right); 2217 return; 2218 end if; 2219 2220 -- Here the result is static, note that, unlike the normal processing 2221 -- in Test_Expression_Is_Foldable, we did *not* check above to see if 2222 -- the right operand raises constraint error, that's because it is not 2223 -- significant if the left operand is decisive. 2224 2225 Set_Is_Static_Expression (N); 2226 2227 -- It does not matter if the right operand raises constraint error if 2228 -- it will not be evaluated. So deal specially with the cases where 2229 -- the right operand is not evaluated. Note that we will fold these 2230 -- cases even if the right operand is non-static, which is fine, but 2231 -- of course in these cases the result is not potentially static. 2232 2233 Left_Int := Expr_Value (Left); 2234 2235 if (Kind = N_And_Then and then Is_False (Left_Int)) 2236 or else (Kind = N_Or_Else and Is_True (Left_Int)) 2237 then 2238 Fold_Uint (N, Left_Int, Rstat); 2239 return; 2240 end if; 2241 2242 -- If first operand not decisive, then it does matter if the right 2243 -- operand raises constraint error, since it will be evaluated, so 2244 -- we simply replace the node with the right operand. Note that this 2245 -- properly propagates Is_Static_Expression and Raises_Constraint_Error 2246 -- (both are set to True in Right). 2247 2248 if Raises_Constraint_Error (Right) then 2249 Rewrite_In_Raise_CE (N, Right); 2250 Check_Non_Static_Context (Left); 2251 return; 2252 end if; 2253 2254 -- Otherwise the result depends on the right operand 2255 2256 Fold_Uint (N, Expr_Value (Right), Rstat); 2257 return; 2258 end Eval_Short_Circuit; 2259 2260 ---------------- 2261 -- Eval_Slice -- 2262 ---------------- 2263 2264 -- Slices can never be static, so the only processing required is to 2265 -- check for non-static context if an explicit range is given. 2266 2267 procedure Eval_Slice (N : Node_Id) is 2268 Drange : constant Node_Id := Discrete_Range (N); 2269 2270 begin 2271 if Nkind (Drange) = N_Range then 2272 Check_Non_Static_Context (Low_Bound (Drange)); 2273 Check_Non_Static_Context (High_Bound (Drange)); 2274 end if; 2275 end Eval_Slice; 2276 2277 ------------------------- 2278 -- Eval_String_Literal -- 2279 ------------------------- 2280 2281 procedure Eval_String_Literal (N : Node_Id) is 2282 Typ : constant Entity_Id := Etype (N); 2283 Bas : constant Entity_Id := Base_Type (Typ); 2284 Xtp : Entity_Id; 2285 Len : Nat; 2286 Lo : Node_Id; 2287 2288 begin 2289 -- Nothing to do if error type (handles cases like default expressions 2290 -- or generics where we have not yet fully resolved the type) 2291 2292 if Bas = Any_Type or else Bas = Any_String then 2293 return; 2294 end if; 2295 2296 -- String literals are static if the subtype is static (RM 4.9(2)), so 2297 -- reset the static expression flag (it was set unconditionally in 2298 -- Analyze_String_Literal) if the subtype is non-static. We tell if 2299 -- the subtype is static by looking at the lower bound. 2300 2301 if Ekind (Typ) = E_String_Literal_Subtype then 2302 if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then 2303 Set_Is_Static_Expression (N, False); 2304 return; 2305 end if; 2306 2307 -- Here if Etype of string literal is normal Etype (not yet possible, 2308 -- but may be possible in future!) 2309 2310 elsif not Is_OK_Static_Expression 2311 (Type_Low_Bound (Etype (First_Index (Typ)))) 2312 then 2313 Set_Is_Static_Expression (N, False); 2314 return; 2315 end if; 2316 2317 -- If original node was a type conversion, then result if non-static 2318 2319 if Nkind (Original_Node (N)) = N_Type_Conversion then 2320 Set_Is_Static_Expression (N, False); 2321 return; 2322 end if; 2323 2324 -- Test for illegal Ada 95 cases. A string literal is illegal in 2325 -- Ada 95 if its bounds are outside the index base type and this 2326 -- index type is static. This can happen in only two ways. Either 2327 -- the string literal is too long, or it is null, and the lower 2328 -- bound is type'First. In either case it is the upper bound that 2329 -- is out of range of the index type. 2330 2331 if Ada_95 then 2332 if Root_Type (Bas) = Standard_String 2333 or else 2334 Root_Type (Bas) = Standard_Wide_String 2335 then 2336 Xtp := Standard_Positive; 2337 else 2338 Xtp := Etype (First_Index (Bas)); 2339 end if; 2340 2341 if Ekind (Typ) = E_String_Literal_Subtype then 2342 Lo := String_Literal_Low_Bound (Typ); 2343 else 2344 Lo := Type_Low_Bound (Etype (First_Index (Typ))); 2345 end if; 2346 2347 Len := String_Length (Strval (N)); 2348 2349 if UI_From_Int (Len) > String_Type_Len (Bas) then 2350 Apply_Compile_Time_Constraint_Error 2351 (N, "string literal too long for}", CE_Length_Check_Failed, 2352 Ent => Bas, 2353 Typ => First_Subtype (Bas)); 2354 2355 elsif Len = 0 2356 and then not Is_Generic_Type (Xtp) 2357 and then 2358 Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp))) 2359 then 2360 Apply_Compile_Time_Constraint_Error 2361 (N, "null string literal not allowed for}", 2362 CE_Length_Check_Failed, 2363 Ent => Bas, 2364 Typ => First_Subtype (Bas)); 2365 end if; 2366 end if; 2367 end Eval_String_Literal; 2368 2369 -------------------------- 2370 -- Eval_Type_Conversion -- 2371 -------------------------- 2372 2373 -- A type conversion is potentially static if its subtype mark is for a 2374 -- static scalar subtype, and its operand expression is potentially static 2375 -- (RM 4.9 (10)) 2376 2377 procedure Eval_Type_Conversion (N : Node_Id) is 2378 Operand : constant Node_Id := Expression (N); 2379 Source_Type : constant Entity_Id := Etype (Operand); 2380 Target_Type : constant Entity_Id := Etype (N); 2381 2382 Stat : Boolean; 2383 Fold : Boolean; 2384 2385 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean; 2386 -- Returns true if type T is an integer type, or if it is a 2387 -- fixed-point type to be treated as an integer (i.e. the flag 2388 -- Conversion_OK is set on the conversion node). 2389 2390 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean; 2391 -- Returns true if type T is a floating-point type, or if it is a 2392 -- fixed-point type that is not to be treated as an integer (i.e. the 2393 -- flag Conversion_OK is not set on the conversion node). 2394 2395 ------------------------------ 2396 -- To_Be_Treated_As_Integer -- 2397 ------------------------------ 2398 2399 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is 2400 begin 2401 return 2402 Is_Integer_Type (T) 2403 or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N)); 2404 end To_Be_Treated_As_Integer; 2405 2406 --------------------------- 2407 -- To_Be_Treated_As_Real -- 2408 --------------------------- 2409 2410 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is 2411 begin 2412 return 2413 Is_Floating_Point_Type (T) 2414 or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N)); 2415 end To_Be_Treated_As_Real; 2416 2417 -- Start of processing for Eval_Type_Conversion 2418 2419 begin 2420 -- Cannot fold if target type is non-static or if semantic error. 2421 2422 if not Is_Static_Subtype (Target_Type) then 2423 Check_Non_Static_Context (Operand); 2424 return; 2425 2426 elsif Error_Posted (N) then 2427 return; 2428 end if; 2429 2430 -- If not foldable we are done 2431 2432 Test_Expression_Is_Foldable (N, Operand, Stat, Fold); 2433 2434 if not Fold then 2435 return; 2436 2437 -- Don't try fold if target type has constraint error bounds 2438 2439 elsif not Is_OK_Static_Subtype (Target_Type) then 2440 Set_Raises_Constraint_Error (N); 2441 return; 2442 end if; 2443 2444 -- Remaining processing depends on operand types. Note that in the 2445 -- following type test, fixed-point counts as real unless the flag 2446 -- Conversion_OK is set, in which case it counts as integer. 2447 2448 -- Fold conversion, case of string type. The result is not static. 2449 2450 if Is_String_Type (Target_Type) then 2451 Fold_Str (N, Strval (Get_String_Val (Operand)), False); 2452 2453 return; 2454 2455 -- Fold conversion, case of integer target type 2456 2457 elsif To_Be_Treated_As_Integer (Target_Type) then 2458 declare 2459 Result : Uint; 2460 2461 begin 2462 -- Integer to integer conversion 2463 2464 if To_Be_Treated_As_Integer (Source_Type) then 2465 Result := Expr_Value (Operand); 2466 2467 -- Real to integer conversion 2468 2469 else 2470 Result := UR_To_Uint (Expr_Value_R (Operand)); 2471 end if; 2472 2473 -- If fixed-point type (Conversion_OK must be set), then the 2474 -- result is logically an integer, but we must replace the 2475 -- conversion with the corresponding real literal, since the 2476 -- type from a semantic point of view is still fixed-point. 2477 2478 if Is_Fixed_Point_Type (Target_Type) then 2479 Fold_Ureal 2480 (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat); 2481 2482 -- Otherwise result is integer literal 2483 2484 else 2485 Fold_Uint (N, Result, Stat); 2486 end if; 2487 end; 2488 2489 -- Fold conversion, case of real target type 2490 2491 elsif To_Be_Treated_As_Real (Target_Type) then 2492 declare 2493 Result : Ureal; 2494 2495 begin 2496 if To_Be_Treated_As_Real (Source_Type) then 2497 Result := Expr_Value_R (Operand); 2498 else 2499 Result := UR_From_Uint (Expr_Value (Operand)); 2500 end if; 2501 2502 Fold_Ureal (N, Result, Stat); 2503 end; 2504 2505 -- Enumeration types 2506 2507 else 2508 Fold_Uint (N, Expr_Value (Operand), Stat); 2509 end if; 2510 2511 if Is_Out_Of_Range (N, Etype (N)) then 2512 Out_Of_Range (N); 2513 end if; 2514 2515 end Eval_Type_Conversion; 2516 2517 ------------------- 2518 -- Eval_Unary_Op -- 2519 ------------------- 2520 2521 -- Predefined unary operators are static functions (RM 4.9(20)) and thus 2522 -- are potentially static if the operand is potentially static (RM 4.9(7)) 2523 2524 procedure Eval_Unary_Op (N : Node_Id) is 2525 Right : constant Node_Id := Right_Opnd (N); 2526 Stat : Boolean; 2527 Fold : Boolean; 2528 2529 begin 2530 -- If not foldable we are done 2531 2532 Test_Expression_Is_Foldable (N, Right, Stat, Fold); 2533 2534 if not Fold then 2535 return; 2536 end if; 2537 2538 -- Fold for integer case 2539 2540 if Is_Integer_Type (Etype (N)) then 2541 declare 2542 Rint : constant Uint := Expr_Value (Right); 2543 Result : Uint; 2544 2545 begin 2546 -- In the case of modular unary plus and abs there is no need 2547 -- to adjust the result of the operation since if the original 2548 -- operand was in bounds the result will be in the bounds of the 2549 -- modular type. However, in the case of modular unary minus the 2550 -- result may go out of the bounds of the modular type and needs 2551 -- adjustment. 2552 2553 if Nkind (N) = N_Op_Plus then 2554 Result := Rint; 2555 2556 elsif Nkind (N) = N_Op_Minus then 2557 if Is_Modular_Integer_Type (Etype (N)) then 2558 Result := (-Rint) mod Modulus (Etype (N)); 2559 else 2560 Result := (-Rint); 2561 end if; 2562 2563 else 2564 pragma Assert (Nkind (N) = N_Op_Abs); 2565 Result := abs Rint; 2566 end if; 2567 2568 Fold_Uint (N, Result, Stat); 2569 end; 2570 2571 -- Fold for real case 2572 2573 elsif Is_Real_Type (Etype (N)) then 2574 declare 2575 Rreal : constant Ureal := Expr_Value_R (Right); 2576 Result : Ureal; 2577 2578 begin 2579 if Nkind (N) = N_Op_Plus then 2580 Result := Rreal; 2581 2582 elsif Nkind (N) = N_Op_Minus then 2583 Result := UR_Negate (Rreal); 2584 2585 else 2586 pragma Assert (Nkind (N) = N_Op_Abs); 2587 Result := abs Rreal; 2588 end if; 2589 2590 Fold_Ureal (N, Result, Stat); 2591 end; 2592 end if; 2593 end Eval_Unary_Op; 2594 2595 ------------------------------- 2596 -- Eval_Unchecked_Conversion -- 2597 ------------------------------- 2598 2599 -- Unchecked conversions can never be static, so the only required 2600 -- processing is to check for a non-static context for the operand. 2601 2602 procedure Eval_Unchecked_Conversion (N : Node_Id) is 2603 begin 2604 Check_Non_Static_Context (Expression (N)); 2605 end Eval_Unchecked_Conversion; 2606 2607 -------------------- 2608 -- Expr_Rep_Value -- 2609 -------------------- 2610 2611 function Expr_Rep_Value (N : Node_Id) return Uint is 2612 Kind : constant Node_Kind := Nkind (N); 2613 Ent : Entity_Id; 2614 2615 begin 2616 if Is_Entity_Name (N) then 2617 Ent := Entity (N); 2618 2619 -- An enumeration literal that was either in the source or 2620 -- created as a result of static evaluation. 2621 2622 if Ekind (Ent) = E_Enumeration_Literal then 2623 return Enumeration_Rep (Ent); 2624 2625 -- A user defined static constant 2626 2627 else 2628 pragma Assert (Ekind (Ent) = E_Constant); 2629 return Expr_Rep_Value (Constant_Value (Ent)); 2630 end if; 2631 2632 -- An integer literal that was either in the source or created 2633 -- as a result of static evaluation. 2634 2635 elsif Kind = N_Integer_Literal then 2636 return Intval (N); 2637 2638 -- A real literal for a fixed-point type. This must be the fixed-point 2639 -- case, either the literal is of a fixed-point type, or it is a bound 2640 -- of a fixed-point type, with type universal real. In either case we 2641 -- obtain the desired value from Corresponding_Integer_Value. 2642 2643 elsif Kind = N_Real_Literal then 2644 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N)))); 2645 return Corresponding_Integer_Value (N); 2646 2647 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero 2648 2649 elsif Kind = N_Attribute_Reference 2650 and then Attribute_Name (N) = Name_Null_Parameter 2651 then 2652 return Uint_0; 2653 2654 -- Otherwise must be character literal 2655 2656 else 2657 pragma Assert (Kind = N_Character_Literal); 2658 Ent := Entity (N); 2659 2660 -- Since Character literals of type Standard.Character don't 2661 -- have any defining character literals built for them, they 2662 -- do not have their Entity set, so just use their Char 2663 -- code. Otherwise for user-defined character literals use 2664 -- their Pos value as usual which is the same as the Rep value. 2665 2666 if No (Ent) then 2667 return UI_From_Int (Int (Char_Literal_Value (N))); 2668 else 2669 return Enumeration_Rep (Ent); 2670 end if; 2671 end if; 2672 end Expr_Rep_Value; 2673 2674 ---------------- 2675 -- Expr_Value -- 2676 ---------------- 2677 2678 function Expr_Value (N : Node_Id) return Uint is 2679 Kind : constant Node_Kind := Nkind (N); 2680 CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size); 2681 Ent : Entity_Id; 2682 Val : Uint; 2683 2684 begin 2685 -- If already in cache, then we know it's compile time known and 2686 -- we can return the value that was previously stored in the cache 2687 -- since compile time known values cannot change :-) 2688 2689 if CV_Ent.N = N then 2690 return CV_Ent.V; 2691 end if; 2692 2693 -- Otherwise proceed to test value 2694 2695 if Is_Entity_Name (N) then 2696 Ent := Entity (N); 2697 2698 -- An enumeration literal that was either in the source or 2699 -- created as a result of static evaluation. 2700 2701 if Ekind (Ent) = E_Enumeration_Literal then 2702 Val := Enumeration_Pos (Ent); 2703 2704 -- A user defined static constant 2705 2706 else 2707 pragma Assert (Ekind (Ent) = E_Constant); 2708 Val := Expr_Value (Constant_Value (Ent)); 2709 end if; 2710 2711 -- An integer literal that was either in the source or created 2712 -- as a result of static evaluation. 2713 2714 elsif Kind = N_Integer_Literal then 2715 Val := Intval (N); 2716 2717 -- A real literal for a fixed-point type. This must be the fixed-point 2718 -- case, either the literal is of a fixed-point type, or it is a bound 2719 -- of a fixed-point type, with type universal real. In either case we 2720 -- obtain the desired value from Corresponding_Integer_Value. 2721 2722 elsif Kind = N_Real_Literal then 2723 2724 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N)))); 2725 Val := Corresponding_Integer_Value (N); 2726 2727 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero 2728 2729 elsif Kind = N_Attribute_Reference 2730 and then Attribute_Name (N) = Name_Null_Parameter 2731 then 2732 Val := Uint_0; 2733 2734 -- Otherwise must be character literal 2735 2736 else 2737 pragma Assert (Kind = N_Character_Literal); 2738 Ent := Entity (N); 2739 2740 -- Since Character literals of type Standard.Character don't 2741 -- have any defining character literals built for them, they 2742 -- do not have their Entity set, so just use their Char 2743 -- code. Otherwise for user-defined character literals use 2744 -- their Pos value as usual. 2745 2746 if No (Ent) then 2747 Val := UI_From_Int (Int (Char_Literal_Value (N))); 2748 else 2749 Val := Enumeration_Pos (Ent); 2750 end if; 2751 end if; 2752 2753 -- Come here with Val set to value to be returned, set cache 2754 2755 CV_Ent.N := N; 2756 CV_Ent.V := Val; 2757 return Val; 2758 end Expr_Value; 2759 2760 ------------------ 2761 -- Expr_Value_E -- 2762 ------------------ 2763 2764 function Expr_Value_E (N : Node_Id) return Entity_Id is 2765 Ent : constant Entity_Id := Entity (N); 2766 2767 begin 2768 if Ekind (Ent) = E_Enumeration_Literal then 2769 return Ent; 2770 else 2771 pragma Assert (Ekind (Ent) = E_Constant); 2772 return Expr_Value_E (Constant_Value (Ent)); 2773 end if; 2774 end Expr_Value_E; 2775 2776 ------------------ 2777 -- Expr_Value_R -- 2778 ------------------ 2779 2780 function Expr_Value_R (N : Node_Id) return Ureal is 2781 Kind : constant Node_Kind := Nkind (N); 2782 Ent : Entity_Id; 2783 Expr : Node_Id; 2784 2785 begin 2786 if Kind = N_Real_Literal then 2787 return Realval (N); 2788 2789 elsif Kind = N_Identifier or else Kind = N_Expanded_Name then 2790 Ent := Entity (N); 2791 pragma Assert (Ekind (Ent) = E_Constant); 2792 return Expr_Value_R (Constant_Value (Ent)); 2793 2794 elsif Kind = N_Integer_Literal then 2795 return UR_From_Uint (Expr_Value (N)); 2796 2797 -- Strange case of VAX literals, which are at this stage transformed 2798 -- into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in 2799 -- Exp_Vfpt for further details. 2800 2801 elsif Vax_Float (Etype (N)) 2802 and then Nkind (N) = N_Unchecked_Type_Conversion 2803 then 2804 Expr := Expression (N); 2805 2806 if Nkind (Expr) = N_Function_Call 2807 and then Present (Parameter_Associations (Expr)) 2808 then 2809 Expr := First (Parameter_Associations (Expr)); 2810 2811 if Nkind (Expr) = N_Real_Literal then 2812 return Realval (Expr); 2813 end if; 2814 end if; 2815 2816 -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0 2817 2818 elsif Kind = N_Attribute_Reference 2819 and then Attribute_Name (N) = Name_Null_Parameter 2820 then 2821 return Ureal_0; 2822 end if; 2823 2824 -- If we fall through, we have a node that cannot be interepreted 2825 -- as a compile time constant. That is definitely an error. 2826 2827 raise Program_Error; 2828 end Expr_Value_R; 2829 2830 ------------------ 2831 -- Expr_Value_S -- 2832 ------------------ 2833 2834 function Expr_Value_S (N : Node_Id) return Node_Id is 2835 begin 2836 if Nkind (N) = N_String_Literal then 2837 return N; 2838 else 2839 pragma Assert (Ekind (Entity (N)) = E_Constant); 2840 return Expr_Value_S (Constant_Value (Entity (N))); 2841 end if; 2842 end Expr_Value_S; 2843 2844 -------------------------- 2845 -- Flag_Non_Static_Expr -- 2846 -------------------------- 2847 2848 procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is 2849 begin 2850 if Error_Posted (Expr) and then not All_Errors_Mode then 2851 return; 2852 else 2853 Error_Msg_F (Msg, Expr); 2854 Why_Not_Static (Expr); 2855 end if; 2856 end Flag_Non_Static_Expr; 2857 2858 -------------- 2859 -- Fold_Str -- 2860 -------------- 2861 2862 procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is 2863 Loc : constant Source_Ptr := Sloc (N); 2864 Typ : constant Entity_Id := Etype (N); 2865 2866 begin 2867 Rewrite (N, Make_String_Literal (Loc, Strval => Val)); 2868 2869 -- We now have the literal with the right value, both the actual type 2870 -- and the expected type of this literal are taken from the expression 2871 -- that was evaluated. 2872 2873 Analyze (N); 2874 Set_Is_Static_Expression (N, Static); 2875 Set_Etype (N, Typ); 2876 Resolve (N); 2877 end Fold_Str; 2878 2879 --------------- 2880 -- Fold_Uint -- 2881 --------------- 2882 2883 procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is 2884 Loc : constant Source_Ptr := Sloc (N); 2885 Typ : Entity_Id := Etype (N); 2886 Ent : Entity_Id; 2887 2888 begin 2889 -- If we are folding a named number, retain the entity in the 2890 -- literal, for ASIS use. 2891 2892 if Is_Entity_Name (N) 2893 and then Ekind (Entity (N)) = E_Named_Integer 2894 then 2895 Ent := Entity (N); 2896 else 2897 Ent := Empty; 2898 end if; 2899 2900 if Is_Private_Type (Typ) then 2901 Typ := Full_View (Typ); 2902 end if; 2903 2904 -- For a result of type integer, subsitute an N_Integer_Literal node 2905 -- for the result of the compile time evaluation of the expression. 2906 2907 if Is_Integer_Type (Typ) then 2908 Rewrite (N, Make_Integer_Literal (Loc, Val)); 2909 Set_Original_Entity (N, Ent); 2910 2911 -- Otherwise we have an enumeration type, and we substitute either 2912 -- an N_Identifier or N_Character_Literal to represent the enumeration 2913 -- literal corresponding to the given value, which must always be in 2914 -- range, because appropriate tests have already been made for this. 2915 2916 else pragma Assert (Is_Enumeration_Type (Typ)); 2917 Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc)); 2918 end if; 2919 2920 -- We now have the literal with the right value, both the actual type 2921 -- and the expected type of this literal are taken from the expression 2922 -- that was evaluated. 2923 2924 Analyze (N); 2925 Set_Is_Static_Expression (N, Static); 2926 Set_Etype (N, Typ); 2927 Resolve (N); 2928 end Fold_Uint; 2929 2930 ---------------- 2931 -- Fold_Ureal -- 2932 ---------------- 2933 2934 procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is 2935 Loc : constant Source_Ptr := Sloc (N); 2936 Typ : constant Entity_Id := Etype (N); 2937 Ent : Entity_Id; 2938 2939 begin 2940 -- If we are folding a named number, retain the entity in the 2941 -- literal, for ASIS use. 2942 2943 if Is_Entity_Name (N) 2944 and then Ekind (Entity (N)) = E_Named_Real 2945 then 2946 Ent := Entity (N); 2947 else 2948 Ent := Empty; 2949 end if; 2950 2951 Rewrite (N, Make_Real_Literal (Loc, Realval => Val)); 2952 Set_Original_Entity (N, Ent); 2953 2954 -- Both the actual and expected type comes from the original expression 2955 2956 Analyze (N); 2957 Set_Is_Static_Expression (N, Static); 2958 Set_Etype (N, Typ); 2959 Resolve (N); 2960 end Fold_Ureal; 2961 2962 --------------- 2963 -- From_Bits -- 2964 --------------- 2965 2966 function From_Bits (B : Bits; T : Entity_Id) return Uint is 2967 V : Uint := Uint_0; 2968 2969 begin 2970 for J in 0 .. B'Last loop 2971 if B (J) then 2972 V := V + 2 ** J; 2973 end if; 2974 end loop; 2975 2976 if Non_Binary_Modulus (T) then 2977 V := V mod Modulus (T); 2978 end if; 2979 2980 return V; 2981 end From_Bits; 2982 2983 -------------------- 2984 -- Get_String_Val -- 2985 -------------------- 2986 2987 function Get_String_Val (N : Node_Id) return Node_Id is 2988 begin 2989 if Nkind (N) = N_String_Literal then 2990 return N; 2991 2992 elsif Nkind (N) = N_Character_Literal then 2993 return N; 2994 2995 else 2996 pragma Assert (Is_Entity_Name (N)); 2997 return Get_String_Val (Constant_Value (Entity (N))); 2998 end if; 2999 end Get_String_Val; 3000 3001 ---------------- 3002 -- Initialize -- 3003 ---------------- 3004 3005 procedure Initialize is 3006 begin 3007 CV_Cache := (others => (Node_High_Bound, Uint_0)); 3008 end Initialize; 3009 3010 -------------------- 3011 -- In_Subrange_Of -- 3012 -------------------- 3013 3014 function In_Subrange_Of 3015 (T1 : Entity_Id; 3016 T2 : Entity_Id; 3017 Fixed_Int : Boolean := False) 3018 return Boolean 3019 is 3020 L1 : Node_Id; 3021 H1 : Node_Id; 3022 3023 L2 : Node_Id; 3024 H2 : Node_Id; 3025 3026 begin 3027 if T1 = T2 or else Is_Subtype_Of (T1, T2) then 3028 return True; 3029 3030 -- Never in range if both types are not scalar. Don't know if this can 3031 -- actually happen, but just in case. 3032 3033 elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then 3034 return False; 3035 3036 else 3037 L1 := Type_Low_Bound (T1); 3038 H1 := Type_High_Bound (T1); 3039 3040 L2 := Type_Low_Bound (T2); 3041 H2 := Type_High_Bound (T2); 3042 3043 -- Check bounds to see if comparison possible at compile time 3044 3045 if Compile_Time_Compare (L1, L2) in Compare_GE 3046 and then 3047 Compile_Time_Compare (H1, H2) in Compare_LE 3048 then 3049 return True; 3050 end if; 3051 3052 -- If bounds not comparable at compile time, then the bounds of T2 3053 -- must be compile time known or we cannot answer the query. 3054 3055 if not Compile_Time_Known_Value (L2) 3056 or else not Compile_Time_Known_Value (H2) 3057 then 3058 return False; 3059 end if; 3060 3061 -- If the bounds of T1 are know at compile time then use these 3062 -- ones, otherwise use the bounds of the base type (which are of 3063 -- course always static). 3064 3065 if not Compile_Time_Known_Value (L1) then 3066 L1 := Type_Low_Bound (Base_Type (T1)); 3067 end if; 3068 3069 if not Compile_Time_Known_Value (H1) then 3070 H1 := Type_High_Bound (Base_Type (T1)); 3071 end if; 3072 3073 -- Fixed point types should be considered as such only if 3074 -- flag Fixed_Int is set to False. 3075 3076 if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2) 3077 or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int) 3078 or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int) 3079 then 3080 return 3081 Expr_Value_R (L2) <= Expr_Value_R (L1) 3082 and then 3083 Expr_Value_R (H2) >= Expr_Value_R (H1); 3084 3085 else 3086 return 3087 Expr_Value (L2) <= Expr_Value (L1) 3088 and then 3089 Expr_Value (H2) >= Expr_Value (H1); 3090 3091 end if; 3092 end if; 3093 3094 -- If any exception occurs, it means that we have some bug in the compiler 3095 -- possibly triggered by a previous error, or by some unforseen peculiar 3096 -- occurrence. However, this is only an optimization attempt, so there is 3097 -- really no point in crashing the compiler. Instead we just decide, too 3098 -- bad, we can't figure out the answer in this case after all. 3099 3100 exception 3101 when others => 3102 3103 -- Debug flag K disables this behavior (useful for debugging) 3104 3105 if Debug_Flag_K then 3106 raise; 3107 else 3108 return False; 3109 end if; 3110 end In_Subrange_Of; 3111 3112 ----------------- 3113 -- Is_In_Range -- 3114 ----------------- 3115 3116 function Is_In_Range 3117 (N : Node_Id; 3118 Typ : Entity_Id; 3119 Fixed_Int : Boolean := False; 3120 Int_Real : Boolean := False) 3121 return Boolean 3122 is 3123 Val : Uint; 3124 Valr : Ureal; 3125 3126 begin 3127 -- Universal types have no range limits, so always in range. 3128 3129 if Typ = Universal_Integer or else Typ = Universal_Real then 3130 return True; 3131 3132 -- Never in range if not scalar type. Don't know if this can 3133 -- actually happen, but our spec allows it, so we must check! 3134 3135 elsif not Is_Scalar_Type (Typ) then 3136 return False; 3137 3138 -- Never in range unless we have a compile time known value. 3139 3140 elsif not Compile_Time_Known_Value (N) then 3141 return False; 3142 3143 else 3144 declare 3145 Lo : constant Node_Id := Type_Low_Bound (Typ); 3146 Hi : constant Node_Id := Type_High_Bound (Typ); 3147 LB_Known : constant Boolean := Compile_Time_Known_Value (Lo); 3148 UB_Known : constant Boolean := Compile_Time_Known_Value (Hi); 3149 3150 begin 3151 -- Fixed point types should be considered as such only in 3152 -- flag Fixed_Int is set to False. 3153 3154 if Is_Floating_Point_Type (Typ) 3155 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) 3156 or else Int_Real 3157 then 3158 Valr := Expr_Value_R (N); 3159 3160 if LB_Known and then Valr >= Expr_Value_R (Lo) 3161 and then UB_Known and then Valr <= Expr_Value_R (Hi) 3162 then 3163 return True; 3164 else 3165 return False; 3166 end if; 3167 3168 else 3169 Val := Expr_Value (N); 3170 3171 if LB_Known and then Val >= Expr_Value (Lo) 3172 and then UB_Known and then Val <= Expr_Value (Hi) 3173 then 3174 return True; 3175 else 3176 return False; 3177 end if; 3178 end if; 3179 end; 3180 end if; 3181 end Is_In_Range; 3182 3183 ------------------- 3184 -- Is_Null_Range -- 3185 ------------------- 3186 3187 function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is 3188 Typ : constant Entity_Id := Etype (Lo); 3189 3190 begin 3191 if not Compile_Time_Known_Value (Lo) 3192 or else not Compile_Time_Known_Value (Hi) 3193 then 3194 return False; 3195 end if; 3196 3197 if Is_Discrete_Type (Typ) then 3198 return Expr_Value (Lo) > Expr_Value (Hi); 3199 3200 else 3201 pragma Assert (Is_Real_Type (Typ)); 3202 return Expr_Value_R (Lo) > Expr_Value_R (Hi); 3203 end if; 3204 end Is_Null_Range; 3205 3206 ----------------------------- 3207 -- Is_OK_Static_Expression -- 3208 ----------------------------- 3209 3210 function Is_OK_Static_Expression (N : Node_Id) return Boolean is 3211 begin 3212 return Is_Static_Expression (N) 3213 and then not Raises_Constraint_Error (N); 3214 end Is_OK_Static_Expression; 3215 3216 ------------------------ 3217 -- Is_OK_Static_Range -- 3218 ------------------------ 3219 3220 -- A static range is a range whose bounds are static expressions, or a 3221 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)). 3222 -- We have already converted range attribute references, so we get the 3223 -- "or" part of this rule without needing a special test. 3224 3225 function Is_OK_Static_Range (N : Node_Id) return Boolean is 3226 begin 3227 return Is_OK_Static_Expression (Low_Bound (N)) 3228 and then Is_OK_Static_Expression (High_Bound (N)); 3229 end Is_OK_Static_Range; 3230 3231 -------------------------- 3232 -- Is_OK_Static_Subtype -- 3233 -------------------------- 3234 3235 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) 3236 -- where neither bound raises constraint error when evaluated. 3237 3238 function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is 3239 Base_T : constant Entity_Id := Base_Type (Typ); 3240 Anc_Subt : Entity_Id; 3241 3242 begin 3243 -- First a quick check on the non static subtype flag. As described 3244 -- in further detail in Einfo, this flag is not decisive in all cases, 3245 -- but if it is set, then the subtype is definitely non-static. 3246 3247 if Is_Non_Static_Subtype (Typ) then 3248 return False; 3249 end if; 3250 3251 Anc_Subt := Ancestor_Subtype (Typ); 3252 3253 if Anc_Subt = Empty then 3254 Anc_Subt := Base_T; 3255 end if; 3256 3257 if Is_Generic_Type (Root_Type (Base_T)) 3258 or else Is_Generic_Actual_Type (Base_T) 3259 then 3260 return False; 3261 3262 -- String types 3263 3264 elsif Is_String_Type (Typ) then 3265 return 3266 Ekind (Typ) = E_String_Literal_Subtype 3267 or else 3268 (Is_OK_Static_Subtype (Component_Type (Typ)) 3269 and then Is_OK_Static_Subtype (Etype (First_Index (Typ)))); 3270 3271 -- Scalar types 3272 3273 elsif Is_Scalar_Type (Typ) then 3274 if Base_T = Typ then 3275 return True; 3276 3277 else 3278 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so 3279 -- use Get_Type_Low,High_Bound. 3280 3281 return Is_OK_Static_Subtype (Anc_Subt) 3282 and then Is_OK_Static_Expression (Type_Low_Bound (Typ)) 3283 and then Is_OK_Static_Expression (Type_High_Bound (Typ)); 3284 end if; 3285 3286 -- Types other than string and scalar types are never static 3287 3288 else 3289 return False; 3290 end if; 3291 end Is_OK_Static_Subtype; 3292 3293 --------------------- 3294 -- Is_Out_Of_Range -- 3295 --------------------- 3296 3297 function Is_Out_Of_Range 3298 (N : Node_Id; 3299 Typ : Entity_Id; 3300 Fixed_Int : Boolean := False; 3301 Int_Real : Boolean := False) 3302 return Boolean 3303 is 3304 Val : Uint; 3305 Valr : Ureal; 3306 3307 begin 3308 -- Universal types have no range limits, so always in range. 3309 3310 if Typ = Universal_Integer or else Typ = Universal_Real then 3311 return False; 3312 3313 -- Never out of range if not scalar type. Don't know if this can 3314 -- actually happen, but our spec allows it, so we must check! 3315 3316 elsif not Is_Scalar_Type (Typ) then 3317 return False; 3318 3319 -- Never out of range if this is a generic type, since the bounds 3320 -- of generic types are junk. Note that if we only checked for 3321 -- static expressions (instead of compile time known values) below, 3322 -- we would not need this check, because values of a generic type 3323 -- can never be static, but they can be known at compile time. 3324 3325 elsif Is_Generic_Type (Typ) then 3326 return False; 3327 3328 -- Never out of range unless we have a compile time known value 3329 3330 elsif not Compile_Time_Known_Value (N) then 3331 return False; 3332 3333 else 3334 declare 3335 Lo : constant Node_Id := Type_Low_Bound (Typ); 3336 Hi : constant Node_Id := Type_High_Bound (Typ); 3337 LB_Known : constant Boolean := Compile_Time_Known_Value (Lo); 3338 UB_Known : constant Boolean := Compile_Time_Known_Value (Hi); 3339 3340 begin 3341 -- Real types (note that fixed-point types are not treated 3342 -- as being of a real type if the flag Fixed_Int is set, 3343 -- since in that case they are regarded as integer types). 3344 3345 if Is_Floating_Point_Type (Typ) 3346 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) 3347 or else Int_Real 3348 then 3349 Valr := Expr_Value_R (N); 3350 3351 if LB_Known and then Valr < Expr_Value_R (Lo) then 3352 return True; 3353 3354 elsif UB_Known and then Expr_Value_R (Hi) < Valr then 3355 return True; 3356 3357 else 3358 return False; 3359 end if; 3360 3361 else 3362 Val := Expr_Value (N); 3363 3364 if LB_Known and then Val < Expr_Value (Lo) then 3365 return True; 3366 3367 elsif UB_Known and then Expr_Value (Hi) < Val then 3368 return True; 3369 3370 else 3371 return False; 3372 end if; 3373 end if; 3374 end; 3375 end if; 3376 end Is_Out_Of_Range; 3377 3378 --------------------- 3379 -- Is_Static_Range -- 3380 --------------------- 3381 3382 -- A static range is a range whose bounds are static expressions, or a 3383 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)). 3384 -- We have already converted range attribute references, so we get the 3385 -- "or" part of this rule without needing a special test. 3386 3387 function Is_Static_Range (N : Node_Id) return Boolean is 3388 begin 3389 return Is_Static_Expression (Low_Bound (N)) 3390 and then Is_Static_Expression (High_Bound (N)); 3391 end Is_Static_Range; 3392 3393 ----------------------- 3394 -- Is_Static_Subtype -- 3395 ----------------------- 3396 3397 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)). 3398 3399 function Is_Static_Subtype (Typ : Entity_Id) return Boolean is 3400 Base_T : constant Entity_Id := Base_Type (Typ); 3401 Anc_Subt : Entity_Id; 3402 3403 begin 3404 -- First a quick check on the non static subtype flag. As described 3405 -- in further detail in Einfo, this flag is not decisive in all cases, 3406 -- but if it is set, then the subtype is definitely non-static. 3407 3408 if Is_Non_Static_Subtype (Typ) then 3409 return False; 3410 end if; 3411 3412 Anc_Subt := Ancestor_Subtype (Typ); 3413 3414 if Anc_Subt = Empty then 3415 Anc_Subt := Base_T; 3416 end if; 3417 3418 if Is_Generic_Type (Root_Type (Base_T)) 3419 or else Is_Generic_Actual_Type (Base_T) 3420 then 3421 return False; 3422 3423 -- String types 3424 3425 elsif Is_String_Type (Typ) then 3426 return 3427 Ekind (Typ) = E_String_Literal_Subtype 3428 or else 3429 (Is_Static_Subtype (Component_Type (Typ)) 3430 and then Is_Static_Subtype (Etype (First_Index (Typ)))); 3431 3432 -- Scalar types 3433 3434 elsif Is_Scalar_Type (Typ) then 3435 if Base_T = Typ then 3436 return True; 3437 3438 else 3439 return Is_Static_Subtype (Anc_Subt) 3440 and then Is_Static_Expression (Type_Low_Bound (Typ)) 3441 and then Is_Static_Expression (Type_High_Bound (Typ)); 3442 end if; 3443 3444 -- Types other than string and scalar types are never static 3445 3446 else 3447 return False; 3448 end if; 3449 end Is_Static_Subtype; 3450 3451 -------------------- 3452 -- Not_Null_Range -- 3453 -------------------- 3454 3455 function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is 3456 Typ : constant Entity_Id := Etype (Lo); 3457 3458 begin 3459 if not Compile_Time_Known_Value (Lo) 3460 or else not Compile_Time_Known_Value (Hi) 3461 then 3462 return False; 3463 end if; 3464 3465 if Is_Discrete_Type (Typ) then 3466 return Expr_Value (Lo) <= Expr_Value (Hi); 3467 3468 else 3469 pragma Assert (Is_Real_Type (Typ)); 3470 3471 return Expr_Value_R (Lo) <= Expr_Value_R (Hi); 3472 end if; 3473 end Not_Null_Range; 3474 3475 ------------- 3476 -- OK_Bits -- 3477 ------------- 3478 3479 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is 3480 begin 3481 -- We allow a maximum of 500,000 bits which seems a reasonable limit 3482 3483 if Bits < 500_000 then 3484 return True; 3485 3486 else 3487 Error_Msg_N ("static value too large, capacity exceeded", N); 3488 return False; 3489 end if; 3490 end OK_Bits; 3491 3492 ------------------ 3493 -- Out_Of_Range -- 3494 ------------------ 3495 3496 procedure Out_Of_Range (N : Node_Id) is 3497 begin 3498 -- If we have the static expression case, then this is an illegality 3499 -- in Ada 95 mode, except that in an instance, we never generate an 3500 -- error (if the error is legitimate, it was already diagnosed in 3501 -- the template). The expression to compute the length of a packed 3502 -- array is attached to the array type itself, and deserves a separate 3503 -- message. 3504 3505 if Is_Static_Expression (N) 3506 and then not In_Instance 3507 and then not In_Inlined_Body 3508 and then Ada_95 3509 then 3510 if Nkind (Parent (N)) = N_Defining_Identifier 3511 and then Is_Array_Type (Parent (N)) 3512 and then Present (Packed_Array_Type (Parent (N))) 3513 and then Present (First_Rep_Item (Parent (N))) 3514 then 3515 Error_Msg_N 3516 ("length of packed array must not exceed Integer''Last", 3517 First_Rep_Item (Parent (N))); 3518 Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1)); 3519 3520 else 3521 Apply_Compile_Time_Constraint_Error 3522 (N, "value not in range of}", CE_Range_Check_Failed); 3523 end if; 3524 3525 -- Here we generate a warning for the Ada 83 case, or when we are 3526 -- in an instance, or when we have a non-static expression case. 3527 3528 else 3529 Apply_Compile_Time_Constraint_Error 3530 (N, "value not in range of}?", CE_Range_Check_Failed); 3531 end if; 3532 end Out_Of_Range; 3533 3534 ------------------------- 3535 -- Rewrite_In_Raise_CE -- 3536 ------------------------- 3537 3538 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is 3539 Typ : constant Entity_Id := Etype (N); 3540 3541 begin 3542 -- If we want to raise CE in the condition of a raise_CE node 3543 -- we may as well get rid of the condition 3544 3545 if Present (Parent (N)) 3546 and then Nkind (Parent (N)) = N_Raise_Constraint_Error 3547 then 3548 Set_Condition (Parent (N), Empty); 3549 3550 -- If the expression raising CE is a N_Raise_CE node, we can use 3551 -- that one. We just preserve the type of the context 3552 3553 elsif Nkind (Exp) = N_Raise_Constraint_Error then 3554 Rewrite (N, Exp); 3555 Set_Etype (N, Typ); 3556 3557 -- We have to build an explicit raise_ce node 3558 3559 else 3560 Rewrite (N, 3561 Make_Raise_Constraint_Error (Sloc (Exp), 3562 Reason => CE_Range_Check_Failed)); 3563 Set_Raises_Constraint_Error (N); 3564 Set_Etype (N, Typ); 3565 end if; 3566 end Rewrite_In_Raise_CE; 3567 3568 --------------------- 3569 -- String_Type_Len -- 3570 --------------------- 3571 3572 function String_Type_Len (Stype : Entity_Id) return Uint is 3573 NT : constant Entity_Id := Etype (First_Index (Stype)); 3574 T : Entity_Id; 3575 3576 begin 3577 if Is_OK_Static_Subtype (NT) then 3578 T := NT; 3579 else 3580 T := Base_Type (NT); 3581 end if; 3582 3583 return Expr_Value (Type_High_Bound (T)) - 3584 Expr_Value (Type_Low_Bound (T)) + 1; 3585 end String_Type_Len; 3586 3587 ------------------------------------ 3588 -- Subtypes_Statically_Compatible -- 3589 ------------------------------------ 3590 3591 function Subtypes_Statically_Compatible 3592 (T1 : Entity_Id; 3593 T2 : Entity_Id) 3594 return Boolean 3595 is 3596 begin 3597 if Is_Scalar_Type (T1) then 3598 3599 -- Definitely compatible if we match 3600 3601 if Subtypes_Statically_Match (T1, T2) then 3602 return True; 3603 3604 -- If either subtype is nonstatic then they're not compatible 3605 3606 elsif not Is_Static_Subtype (T1) 3607 or else not Is_Static_Subtype (T2) 3608 then 3609 return False; 3610 3611 -- If either type has constraint error bounds, then consider that 3612 -- they match to avoid junk cascaded errors here. 3613 3614 elsif not Is_OK_Static_Subtype (T1) 3615 or else not Is_OK_Static_Subtype (T2) 3616 then 3617 return True; 3618 3619 -- Base types must match, but we don't check that (should 3620 -- we???) but we do at least check that both types are 3621 -- real, or both types are not real. 3622 3623 elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then 3624 return False; 3625 3626 -- Here we check the bounds 3627 3628 else 3629 declare 3630 LB1 : constant Node_Id := Type_Low_Bound (T1); 3631 HB1 : constant Node_Id := Type_High_Bound (T1); 3632 LB2 : constant Node_Id := Type_Low_Bound (T2); 3633 HB2 : constant Node_Id := Type_High_Bound (T2); 3634 3635 begin 3636 if Is_Real_Type (T1) then 3637 return 3638 (Expr_Value_R (LB1) > Expr_Value_R (HB1)) 3639 or else 3640 (Expr_Value_R (LB2) <= Expr_Value_R (LB1) 3641 and then 3642 Expr_Value_R (HB1) <= Expr_Value_R (HB2)); 3643 3644 else 3645 return 3646 (Expr_Value (LB1) > Expr_Value (HB1)) 3647 or else 3648 (Expr_Value (LB2) <= Expr_Value (LB1) 3649 and then 3650 Expr_Value (HB1) <= Expr_Value (HB2)); 3651 end if; 3652 end; 3653 end if; 3654 3655 elsif Is_Access_Type (T1) then 3656 return not Is_Constrained (T2) 3657 or else Subtypes_Statically_Match 3658 (Designated_Type (T1), Designated_Type (T2)); 3659 3660 else 3661 return (Is_Composite_Type (T1) and then not Is_Constrained (T2)) 3662 or else Subtypes_Statically_Match (T1, T2); 3663 end if; 3664 end Subtypes_Statically_Compatible; 3665 3666 ------------------------------- 3667 -- Subtypes_Statically_Match -- 3668 ------------------------------- 3669 3670 -- Subtypes statically match if they have statically matching constraints 3671 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if 3672 -- they are the same identical constraint, or if they are static and the 3673 -- values match (RM 4.9.1(1)). 3674 3675 function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is 3676 begin 3677 -- A type always statically matches itself 3678 3679 if T1 = T2 then 3680 return True; 3681 3682 -- Scalar types 3683 3684 elsif Is_Scalar_Type (T1) then 3685 3686 -- Base types must be the same 3687 3688 if Base_Type (T1) /= Base_Type (T2) then 3689 return False; 3690 end if; 3691 3692 -- A constrained numeric subtype never matches an unconstrained 3693 -- subtype, i.e. both types must be constrained or unconstrained. 3694 3695 -- To understand the requirement for this test, see RM 4.9.1(1). 3696 -- As is made clear in RM 3.5.4(11), type Integer, for example 3697 -- is a constrained subtype with constraint bounds matching the 3698 -- bounds of its corresponding uncontrained base type. In this 3699 -- situation, Integer and Integer'Base do not statically match, 3700 -- even though they have the same bounds. 3701 3702 -- We only apply this test to types in Standard and types that 3703 -- appear in user programs. That way, we do not have to be 3704 -- too careful about setting Is_Constrained right for itypes. 3705 3706 if Is_Numeric_Type (T1) 3707 and then (Is_Constrained (T1) /= Is_Constrained (T2)) 3708 and then (Scope (T1) = Standard_Standard 3709 or else Comes_From_Source (T1)) 3710 and then (Scope (T2) = Standard_Standard 3711 or else Comes_From_Source (T2)) 3712 then 3713 return False; 3714 end if; 3715 3716 -- If there was an error in either range, then just assume 3717 -- the types statically match to avoid further junk errors 3718 3719 if Error_Posted (Scalar_Range (T1)) 3720 or else 3721 Error_Posted (Scalar_Range (T2)) 3722 then 3723 return True; 3724 end if; 3725 3726 -- Otherwise both types have bound that can be compared 3727 3728 declare 3729 LB1 : constant Node_Id := Type_Low_Bound (T1); 3730 HB1 : constant Node_Id := Type_High_Bound (T1); 3731 LB2 : constant Node_Id := Type_Low_Bound (T2); 3732 HB2 : constant Node_Id := Type_High_Bound (T2); 3733 3734 begin 3735 -- If the bounds are the same tree node, then match 3736 3737 if LB1 = LB2 and then HB1 = HB2 then 3738 return True; 3739 3740 -- Otherwise bounds must be static and identical value 3741 3742 else 3743 if not Is_Static_Subtype (T1) 3744 or else not Is_Static_Subtype (T2) 3745 then 3746 return False; 3747 3748 -- If either type has constraint error bounds, then say 3749 -- that they match to avoid junk cascaded errors here. 3750 3751 elsif not Is_OK_Static_Subtype (T1) 3752 or else not Is_OK_Static_Subtype (T2) 3753 then 3754 return True; 3755 3756 elsif Is_Real_Type (T1) then 3757 return 3758 (Expr_Value_R (LB1) = Expr_Value_R (LB2)) 3759 and then 3760 (Expr_Value_R (HB1) = Expr_Value_R (HB2)); 3761 3762 else 3763 return 3764 Expr_Value (LB1) = Expr_Value (LB2) 3765 and then 3766 Expr_Value (HB1) = Expr_Value (HB2); 3767 end if; 3768 end if; 3769 end; 3770 3771 -- Type with discriminants 3772 3773 elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then 3774 if Has_Discriminants (T1) /= Has_Discriminants (T2) then 3775 return False; 3776 end if; 3777 3778 declare 3779 DL1 : constant Elist_Id := Discriminant_Constraint (T1); 3780 DL2 : constant Elist_Id := Discriminant_Constraint (T2); 3781 3782 DA1 : Elmt_Id := First_Elmt (DL1); 3783 DA2 : Elmt_Id := First_Elmt (DL2); 3784 3785 begin 3786 if DL1 = DL2 then 3787 return True; 3788 3789 elsif Is_Constrained (T1) /= Is_Constrained (T2) then 3790 return False; 3791 end if; 3792 3793 while Present (DA1) loop 3794 declare 3795 Expr1 : constant Node_Id := Node (DA1); 3796 Expr2 : constant Node_Id := Node (DA2); 3797 3798 begin 3799 if not Is_Static_Expression (Expr1) 3800 or else not Is_Static_Expression (Expr2) 3801 then 3802 return False; 3803 3804 -- If either expression raised a constraint error, 3805 -- consider the expressions as matching, since this 3806 -- helps to prevent cascading errors. 3807 3808 elsif Raises_Constraint_Error (Expr1) 3809 or else Raises_Constraint_Error (Expr2) 3810 then 3811 null; 3812 3813 elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then 3814 return False; 3815 end if; 3816 end; 3817 3818 Next_Elmt (DA1); 3819 Next_Elmt (DA2); 3820 end loop; 3821 end; 3822 3823 return True; 3824 3825 -- A definite type does not match an indefinite or classwide type. 3826 3827 elsif 3828 Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2) 3829 then 3830 return False; 3831 3832 -- Array type 3833 3834 elsif Is_Array_Type (T1) then 3835 3836 -- If either subtype is unconstrained then both must be, 3837 -- and if both are unconstrained then no further checking 3838 -- is needed. 3839 3840 if not Is_Constrained (T1) or else not Is_Constrained (T2) then 3841 return not (Is_Constrained (T1) or else Is_Constrained (T2)); 3842 end if; 3843 3844 -- Both subtypes are constrained, so check that the index 3845 -- subtypes statically match. 3846 3847 declare 3848 Index1 : Node_Id := First_Index (T1); 3849 Index2 : Node_Id := First_Index (T2); 3850 3851 begin 3852 while Present (Index1) loop 3853 if not 3854 Subtypes_Statically_Match (Etype (Index1), Etype (Index2)) 3855 then 3856 return False; 3857 end if; 3858 3859 Next_Index (Index1); 3860 Next_Index (Index2); 3861 end loop; 3862 3863 return True; 3864 end; 3865 3866 elsif Is_Access_Type (T1) then 3867 return Subtypes_Statically_Match 3868 (Designated_Type (T1), 3869 Designated_Type (T2)); 3870 3871 -- All other types definitely match 3872 3873 else 3874 return True; 3875 end if; 3876 end Subtypes_Statically_Match; 3877 3878 ---------- 3879 -- Test -- 3880 ---------- 3881 3882 function Test (Cond : Boolean) return Uint is 3883 begin 3884 if Cond then 3885 return Uint_1; 3886 else 3887 return Uint_0; 3888 end if; 3889 end Test; 3890 3891 --------------------------------- 3892 -- Test_Expression_Is_Foldable -- 3893 --------------------------------- 3894 3895 -- One operand case 3896 3897 procedure Test_Expression_Is_Foldable 3898 (N : Node_Id; 3899 Op1 : Node_Id; 3900 Stat : out Boolean; 3901 Fold : out Boolean) 3902 is 3903 begin 3904 Stat := False; 3905 3906 -- If operand is Any_Type, just propagate to result and do not 3907 -- try to fold, this prevents cascaded errors. 3908 3909 if Etype (Op1) = Any_Type then 3910 Set_Etype (N, Any_Type); 3911 Fold := False; 3912 return; 3913 3914 -- If operand raises constraint error, then replace node N with the 3915 -- raise constraint error node, and we are obviously not foldable. 3916 -- Note that this replacement inherits the Is_Static_Expression flag 3917 -- from the operand. 3918 3919 elsif Raises_Constraint_Error (Op1) then 3920 Rewrite_In_Raise_CE (N, Op1); 3921 Fold := False; 3922 return; 3923 3924 -- If the operand is not static, then the result is not static, and 3925 -- all we have to do is to check the operand since it is now known 3926 -- to appear in a non-static context. 3927 3928 elsif not Is_Static_Expression (Op1) then 3929 Check_Non_Static_Context (Op1); 3930 Fold := Compile_Time_Known_Value (Op1); 3931 return; 3932 3933 -- An expression of a formal modular type is not foldable because 3934 -- the modulus is unknown. 3935 3936 elsif Is_Modular_Integer_Type (Etype (Op1)) 3937 and then Is_Generic_Type (Etype (Op1)) 3938 then 3939 Check_Non_Static_Context (Op1); 3940 Fold := False; 3941 return; 3942 3943 -- Here we have the case of an operand whose type is OK, which is 3944 -- static, and which does not raise constraint error, we can fold. 3945 3946 else 3947 Set_Is_Static_Expression (N); 3948 Fold := True; 3949 Stat := True; 3950 end if; 3951 end Test_Expression_Is_Foldable; 3952 3953 -- Two operand case 3954 3955 procedure Test_Expression_Is_Foldable 3956 (N : Node_Id; 3957 Op1 : Node_Id; 3958 Op2 : Node_Id; 3959 Stat : out Boolean; 3960 Fold : out Boolean) 3961 is 3962 Rstat : constant Boolean := Is_Static_Expression (Op1) 3963 and then Is_Static_Expression (Op2); 3964 3965 begin 3966 Stat := False; 3967 3968 -- If either operand is Any_Type, just propagate to result and 3969 -- do not try to fold, this prevents cascaded errors. 3970 3971 if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then 3972 Set_Etype (N, Any_Type); 3973 Fold := False; 3974 return; 3975 3976 -- If left operand raises constraint error, then replace node N with 3977 -- the raise constraint error node, and we are obviously not foldable. 3978 -- Is_Static_Expression is set from the two operands in the normal way, 3979 -- and we check the right operand if it is in a non-static context. 3980 3981 elsif Raises_Constraint_Error (Op1) then 3982 if not Rstat then 3983 Check_Non_Static_Context (Op2); 3984 end if; 3985 3986 Rewrite_In_Raise_CE (N, Op1); 3987 Set_Is_Static_Expression (N, Rstat); 3988 Fold := False; 3989 return; 3990 3991 -- Similar processing for the case of the right operand. Note that 3992 -- we don't use this routine for the short-circuit case, so we do 3993 -- not have to worry about that special case here. 3994 3995 elsif Raises_Constraint_Error (Op2) then 3996 if not Rstat then 3997 Check_Non_Static_Context (Op1); 3998 end if; 3999 4000 Rewrite_In_Raise_CE (N, Op2); 4001 Set_Is_Static_Expression (N, Rstat); 4002 Fold := False; 4003 return; 4004 4005 -- Exclude expressions of a generic modular type, as above. 4006 4007 elsif Is_Modular_Integer_Type (Etype (Op1)) 4008 and then Is_Generic_Type (Etype (Op1)) 4009 then 4010 Check_Non_Static_Context (Op1); 4011 Fold := False; 4012 return; 4013 4014 -- If result is not static, then check non-static contexts on operands 4015 -- since one of them may be static and the other one may not be static 4016 4017 elsif not Rstat then 4018 Check_Non_Static_Context (Op1); 4019 Check_Non_Static_Context (Op2); 4020 Fold := Compile_Time_Known_Value (Op1) 4021 and then Compile_Time_Known_Value (Op2); 4022 return; 4023 4024 -- Else result is static and foldable. Both operands are static, 4025 -- and neither raises constraint error, so we can definitely fold. 4026 4027 else 4028 Set_Is_Static_Expression (N); 4029 Fold := True; 4030 Stat := True; 4031 return; 4032 end if; 4033 end Test_Expression_Is_Foldable; 4034 4035 -------------- 4036 -- To_Bits -- 4037 -------------- 4038 4039 procedure To_Bits (U : Uint; B : out Bits) is 4040 begin 4041 for J in 0 .. B'Last loop 4042 B (J) := (U / (2 ** J)) mod 2 /= 0; 4043 end loop; 4044 end To_Bits; 4045 4046 -------------------- 4047 -- Why_Not_Static -- 4048 -------------------- 4049 4050 procedure Why_Not_Static (Expr : Node_Id) is 4051 N : constant Node_Id := Original_Node (Expr); 4052 Typ : Entity_Id; 4053 E : Entity_Id; 4054 4055 procedure Why_Not_Static_List (L : List_Id); 4056 -- A version that can be called on a list of expressions. Finds 4057 -- all non-static violations in any element of the list. 4058 4059 ------------------------- 4060 -- Why_Not_Static_List -- 4061 ------------------------- 4062 4063 procedure Why_Not_Static_List (L : List_Id) is 4064 N : Node_Id; 4065 4066 begin 4067 if Is_Non_Empty_List (L) then 4068 N := First (L); 4069 while Present (N) loop 4070 Why_Not_Static (N); 4071 Next (N); 4072 end loop; 4073 end if; 4074 end Why_Not_Static_List; 4075 4076 -- Start of processing for Why_Not_Static 4077 4078 begin 4079 -- If in ACATS mode (debug flag 2), then suppress all these 4080 -- messages, this avoids massive updates to the ACATS base line. 4081 4082 if Debug_Flag_2 then 4083 return; 4084 end if; 4085 4086 -- Ignore call on error or empty node 4087 4088 if No (Expr) or else Nkind (Expr) = N_Error then 4089 return; 4090 end if; 4091 4092 -- Preprocessing for sub expressions 4093 4094 if Nkind (Expr) in N_Subexpr then 4095 4096 -- Nothing to do if expression is static 4097 4098 if Is_OK_Static_Expression (Expr) then 4099 return; 4100 end if; 4101 4102 -- Test for constraint error raised 4103 4104 if Raises_Constraint_Error (Expr) then 4105 Error_Msg_N 4106 ("expression raises exception, cannot be static " & 4107 "('R'M 4.9(34))!", N); 4108 return; 4109 end if; 4110 4111 -- If no type, then something is pretty wrong, so ignore 4112 4113 Typ := Etype (Expr); 4114 4115 if No (Typ) then 4116 return; 4117 end if; 4118 4119 -- Type must be scalar or string type 4120 4121 if not Is_Scalar_Type (Typ) 4122 and then not Is_String_Type (Typ) 4123 then 4124 Error_Msg_N 4125 ("static expression must have scalar or string type " & 4126 "('R'M 4.9(2))!", N); 4127 return; 4128 end if; 4129 end if; 4130 4131 -- If we got through those checks, test particular node kind 4132 4133 case Nkind (N) is 4134 when N_Expanded_Name | N_Identifier | N_Operator_Symbol => 4135 E := Entity (N); 4136 4137 if Is_Named_Number (E) then 4138 null; 4139 4140 elsif Ekind (E) = E_Constant then 4141 if not Is_Static_Expression (Constant_Value (E)) then 4142 Error_Msg_NE 4143 ("& is not a static constant ('R'M 4.9(5))!", N, E); 4144 end if; 4145 4146 else 4147 Error_Msg_NE 4148 ("& is not static constant or named number " & 4149 "('R'M 4.9(5))!", N, E); 4150 end if; 4151 4152 when N_Binary_Op | N_And_Then | N_Or_Else | N_In | N_Not_In => 4153 if Nkind (N) in N_Op_Shift then 4154 Error_Msg_N 4155 ("shift functions are never static ('R'M 4.9(6,18))!", N); 4156 4157 else 4158 Why_Not_Static (Left_Opnd (N)); 4159 Why_Not_Static (Right_Opnd (N)); 4160 end if; 4161 4162 when N_Unary_Op => 4163 Why_Not_Static (Right_Opnd (N)); 4164 4165 when N_Attribute_Reference => 4166 Why_Not_Static_List (Expressions (N)); 4167 4168 E := Etype (Prefix (N)); 4169 4170 if E = Standard_Void_Type then 4171 return; 4172 end if; 4173 4174 -- Special case non-scalar'Size since this is a common error 4175 4176 if Attribute_Name (N) = Name_Size then 4177 Error_Msg_N 4178 ("size attribute is only static for scalar type " & 4179 "('R'M 4.9(7,8))", N); 4180 4181 -- Flag array cases 4182 4183 elsif Is_Array_Type (E) then 4184 if Attribute_Name (N) /= Name_First 4185 and then 4186 Attribute_Name (N) /= Name_Last 4187 and then 4188 Attribute_Name (N) /= Name_Length 4189 then 4190 Error_Msg_N 4191 ("static array attribute must be Length, First, or Last " & 4192 "('R'M 4.9(8))!", N); 4193 4194 -- Since we know the expression is not-static (we already 4195 -- tested for this, must mean array is not static). 4196 4197 else 4198 Error_Msg_N 4199 ("prefix is non-static array ('R'M 4.9(8))!", Prefix (N)); 4200 end if; 4201 4202 return; 4203 4204 -- Special case generic types, since again this is a common 4205 -- source of confusion. 4206 4207 elsif Is_Generic_Actual_Type (E) 4208 or else 4209 Is_Generic_Type (E) 4210 then 4211 Error_Msg_N 4212 ("attribute of generic type is never static " & 4213 "('R'M 4.9(7,8))!", N); 4214 4215 elsif Is_Static_Subtype (E) then 4216 null; 4217 4218 elsif Is_Scalar_Type (E) then 4219 Error_Msg_N 4220 ("prefix type for attribute is not static scalar subtype " & 4221 "('R'M 4.9(7))!", N); 4222 4223 else 4224 Error_Msg_N 4225 ("static attribute must apply to array/scalar type " & 4226 "('R'M 4.9(7,8))!", N); 4227 end if; 4228 4229 when N_String_Literal => 4230 Error_Msg_N 4231 ("subtype of string literal is non-static ('R'M 4.9(4))!", N); 4232 4233 when N_Explicit_Dereference => 4234 Error_Msg_N 4235 ("explicit dereference is never static ('R'M 4.9)!", N); 4236 4237 when N_Function_Call => 4238 Why_Not_Static_List (Parameter_Associations (N)); 4239 Error_Msg_N ("non-static function call ('R'M 4.9(6,18))!", N); 4240 4241 when N_Parameter_Association => 4242 Why_Not_Static (Explicit_Actual_Parameter (N)); 4243 4244 when N_Indexed_Component => 4245 Error_Msg_N 4246 ("indexed component is never static ('R'M 4.9)!", N); 4247 4248 when N_Procedure_Call_Statement => 4249 Error_Msg_N 4250 ("procedure call is never static ('R'M 4.9)!", N); 4251 4252 when N_Qualified_Expression => 4253 Why_Not_Static (Expression (N)); 4254 4255 when N_Aggregate | N_Extension_Aggregate => 4256 Error_Msg_N 4257 ("an aggregate is never static ('R'M 4.9)!", N); 4258 4259 when N_Range => 4260 Why_Not_Static (Low_Bound (N)); 4261 Why_Not_Static (High_Bound (N)); 4262 4263 when N_Range_Constraint => 4264 Why_Not_Static (Range_Expression (N)); 4265 4266 when N_Subtype_Indication => 4267 Why_Not_Static (Constraint (N)); 4268 4269 when N_Selected_Component => 4270 Error_Msg_N 4271 ("selected component is never static ('R'M 4.9)!", N); 4272 4273 when N_Slice => 4274 Error_Msg_N 4275 ("slice is never static ('R'M 4.9)!", N); 4276 4277 when N_Type_Conversion => 4278 Why_Not_Static (Expression (N)); 4279 4280 if not Is_Scalar_Type (Etype (Prefix (N))) 4281 or else not Is_Static_Subtype (Etype (Prefix (N))) 4282 then 4283 Error_Msg_N 4284 ("static conversion requires static scalar subtype result " & 4285 "('R'M 4.9(9))!", N); 4286 end if; 4287 4288 when N_Unchecked_Type_Conversion => 4289 Error_Msg_N 4290 ("unchecked type conversion is never static ('R'M 4.9)!", N); 4291 4292 when others => 4293 null; 4294 4295 end case; 4296 end Why_Not_Static; 4297 4298end Sem_Eval; 4299