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