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