1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- C H E C K S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2020, 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 Casing; use Casing; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Elists; use Elists; 31with Eval_Fat; use Eval_Fat; 32with Exp_Ch11; use Exp_Ch11; 33with Exp_Ch4; use Exp_Ch4; 34with Exp_Pakd; use Exp_Pakd; 35with Exp_Util; use Exp_Util; 36with Expander; use Expander; 37with Freeze; use Freeze; 38with Lib; use Lib; 39with Nlists; use Nlists; 40with Nmake; use Nmake; 41with Opt; use Opt; 42with Output; use Output; 43with Restrict; use Restrict; 44with Rident; use Rident; 45with Rtsfind; use Rtsfind; 46with Sem; use Sem; 47with Sem_Aux; use Sem_Aux; 48with Sem_Ch3; use Sem_Ch3; 49with Sem_Ch8; use Sem_Ch8; 50with Sem_Disp; use Sem_Disp; 51with Sem_Eval; use Sem_Eval; 52with Sem_Mech; use Sem_Mech; 53with Sem_Res; use Sem_Res; 54with Sem_Util; use Sem_Util; 55with Sem_Warn; use Sem_Warn; 56with Sinfo; use Sinfo; 57with Sinput; use Sinput; 58with Snames; use Snames; 59with Sprint; use Sprint; 60with Stand; use Stand; 61with Stringt; use Stringt; 62with Targparm; use Targparm; 63with Tbuild; use Tbuild; 64with Ttypes; use Ttypes; 65with Validsw; use Validsw; 66 67package body Checks is 68 69 -- General note: many of these routines are concerned with generating 70 -- checking code to make sure that constraint error is raised at runtime. 71 -- Clearly this code is only needed if the expander is active, since 72 -- otherwise we will not be generating code or going into the runtime 73 -- execution anyway. 74 75 -- We therefore disconnect most of these checks if the expander is 76 -- inactive. This has the additional benefit that we do not need to 77 -- worry about the tree being messed up by previous errors (since errors 78 -- turn off expansion anyway). 79 80 -- There are a few exceptions to the above rule. For instance routines 81 -- such as Apply_Scalar_Range_Check that do not insert any code can be 82 -- safely called even when the Expander is inactive (but Errors_Detected 83 -- is 0). The benefit of executing this code when expansion is off, is 84 -- the ability to emit constraint error warning for static expressions 85 -- even when we are not generating code. 86 87 -- The above is modified in gnatprove mode to ensure that proper check 88 -- flags are always placed, even if expansion is off. 89 90 ------------------------------------- 91 -- Suppression of Redundant Checks -- 92 ------------------------------------- 93 94 -- This unit implements a limited circuit for removal of redundant 95 -- checks. The processing is based on a tracing of simple sequential 96 -- flow. For any sequence of statements, we save expressions that are 97 -- marked to be checked, and then if the same expression appears later 98 -- with the same check, then under certain circumstances, the second 99 -- check can be suppressed. 100 101 -- Basically, we can suppress the check if we know for certain that 102 -- the previous expression has been elaborated (together with its 103 -- check), and we know that the exception frame is the same, and that 104 -- nothing has happened to change the result of the exception. 105 106 -- Let us examine each of these three conditions in turn to describe 107 -- how we ensure that this condition is met. 108 109 -- First, we need to know for certain that the previous expression has 110 -- been executed. This is done principally by the mechanism of calling 111 -- Conditional_Statements_Begin at the start of any statement sequence 112 -- and Conditional_Statements_End at the end. The End call causes all 113 -- checks remembered since the Begin call to be discarded. This does 114 -- miss a few cases, notably the case of a nested BEGIN-END block with 115 -- no exception handlers. But the important thing is to be conservative. 116 -- The other protection is that all checks are discarded if a label 117 -- is encountered, since then the assumption of sequential execution 118 -- is violated, and we don't know enough about the flow. 119 120 -- Second, we need to know that the exception frame is the same. We 121 -- do this by killing all remembered checks when we enter a new frame. 122 -- Again, that's over-conservative, but generally the cases we can help 123 -- with are pretty local anyway (like the body of a loop for example). 124 125 -- Third, we must be sure to forget any checks which are no longer valid. 126 -- This is done by two mechanisms, first the Kill_Checks_Variable call is 127 -- used to note any changes to local variables. We only attempt to deal 128 -- with checks involving local variables, so we do not need to worry 129 -- about global variables. Second, a call to any non-global procedure 130 -- causes us to abandon all stored checks, since such a all may affect 131 -- the values of any local variables. 132 133 -- The following define the data structures used to deal with remembering 134 -- checks so that redundant checks can be eliminated as described above. 135 136 -- Right now, the only expressions that we deal with are of the form of 137 -- simple local objects (either declared locally, or IN parameters) or 138 -- such objects plus/minus a compile time known constant. We can do 139 -- more later on if it seems worthwhile, but this catches many simple 140 -- cases in practice. 141 142 -- The following record type reflects a single saved check. An entry 143 -- is made in the stack of saved checks if and only if the expression 144 -- has been elaborated with the indicated checks. 145 146 type Saved_Check is record 147 Killed : Boolean; 148 -- Set True if entry is killed by Kill_Checks 149 150 Entity : Entity_Id; 151 -- The entity involved in the expression that is checked 152 153 Offset : Uint; 154 -- A compile time value indicating the result of adding or 155 -- subtracting a compile time value. This value is to be 156 -- added to the value of the Entity. A value of zero is 157 -- used for the case of a simple entity reference. 158 159 Check_Type : Character; 160 -- This is set to 'R' for a range check (in which case Target_Type 161 -- is set to the target type for the range check) or to 'O' for an 162 -- overflow check (in which case Target_Type is set to Empty). 163 164 Target_Type : Entity_Id; 165 -- Used only if Do_Range_Check is set. Records the target type for 166 -- the check. We need this, because a check is a duplicate only if 167 -- it has the same target type (or more accurately one with a 168 -- range that is smaller or equal to the stored target type of a 169 -- saved check). 170 end record; 171 172 -- The following table keeps track of saved checks. Rather than use an 173 -- extensible table, we just use a table of fixed size, and we discard 174 -- any saved checks that do not fit. That's very unlikely to happen and 175 -- this is only an optimization in any case. 176 177 Saved_Checks : array (Int range 1 .. 200) of Saved_Check; 178 -- Array of saved checks 179 180 Num_Saved_Checks : Nat := 0; 181 -- Number of saved checks 182 183 -- The following stack keeps track of statement ranges. It is treated 184 -- as a stack. When Conditional_Statements_Begin is called, an entry 185 -- is pushed onto this stack containing the value of Num_Saved_Checks 186 -- at the time of the call. Then when Conditional_Statements_End is 187 -- called, this value is popped off and used to reset Num_Saved_Checks. 188 189 -- Note: again, this is a fixed length stack with a size that should 190 -- always be fine. If the value of the stack pointer goes above the 191 -- limit, then we just forget all saved checks. 192 193 Saved_Checks_Stack : array (Int range 1 .. 100) of Nat; 194 Saved_Checks_TOS : Nat := 0; 195 196 ----------------------- 197 -- Local Subprograms -- 198 ----------------------- 199 200 procedure Apply_Arithmetic_Overflow_Strict (N : Node_Id); 201 -- Used to apply arithmetic overflow checks for all cases except operators 202 -- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we 203 -- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N can be a 204 -- signed integer arithmetic operator (but not an if or case expression). 205 -- It is also called for types other than signed integers. 206 207 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id); 208 -- Used to apply arithmetic overflow checks for the case where the overflow 209 -- checking mode is MINIMIZED or ELIMINATED and we have a signed integer 210 -- arithmetic op (which includes the case of if and case expressions). Note 211 -- that Do_Overflow_Check may or may not be set for node Op. In these modes 212 -- we have work to do even if overflow checking is suppressed. 213 214 procedure Apply_Division_Check 215 (N : Node_Id; 216 Rlo : Uint; 217 Rhi : Uint; 218 ROK : Boolean); 219 -- N is an N_Op_Div, N_Op_Rem, or N_Op_Mod node. This routine applies 220 -- division checks as required if the Do_Division_Check flag is set. 221 -- Rlo and Rhi give the possible range of the right operand, these values 222 -- can be referenced and trusted only if ROK is set True. 223 224 procedure Apply_Float_Conversion_Check 225 (Expr : Node_Id; 226 Target_Typ : Entity_Id); 227 -- The checks on a conversion from a floating-point type to an integer 228 -- type are delicate. They have to be performed before conversion, they 229 -- have to raise an exception when the operand is a NaN, and rounding must 230 -- be taken into account to determine the safe bounds of the operand. 231 232 procedure Apply_Selected_Length_Checks 233 (Expr : Node_Id; 234 Target_Typ : Entity_Id; 235 Source_Typ : Entity_Id; 236 Do_Static : Boolean); 237 -- This is the subprogram that does all the work for Apply_Length_Check 238 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as 239 -- described for the above routines. The Do_Static flag indicates that 240 -- only a static check is to be done. 241 242 procedure Compute_Range_For_Arithmetic_Op 243 (Op : Node_Kind; 244 Lo_Left : Uint; 245 Hi_Left : Uint; 246 Lo_Right : Uint; 247 Hi_Right : Uint; 248 OK : out Boolean; 249 Lo : out Uint; 250 Hi : out Uint); 251 -- Given an integer arithmetical operation Op and the range of values of 252 -- its operand(s), try to compute a conservative estimate of the possible 253 -- range of values for the result of the operation. Thus if OK is True on 254 -- return, the result is known to lie in the range Lo .. Hi (inclusive). 255 -- If OK is false, both Lo and Hi are set to No_Uint. 256 257 type Check_Type is new Check_Id range Access_Check .. Division_Check; 258 function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean; 259 -- This function is used to see if an access or division by zero check is 260 -- needed. The check is to be applied to a single variable appearing in the 261 -- source, and N is the node for the reference. If N is not of this form, 262 -- True is returned with no further processing. If N is of the right form, 263 -- then further processing determines if the given Check is needed. 264 -- 265 -- The particular circuit is to see if we have the case of a check that is 266 -- not needed because it appears in the right operand of a short circuited 267 -- conditional where the left operand guards the check. For example: 268 -- 269 -- if Var = 0 or else Q / Var > 12 then 270 -- ... 271 -- end if; 272 -- 273 -- In this example, the division check is not required. At the same time 274 -- we can issue warnings for suspicious use of non-short-circuited forms, 275 -- such as: 276 -- 277 -- if Var = 0 or Q / Var > 12 then 278 -- ... 279 -- end if; 280 281 procedure Find_Check 282 (Expr : Node_Id; 283 Check_Type : Character; 284 Target_Type : Entity_Id; 285 Entry_OK : out Boolean; 286 Check_Num : out Nat; 287 Ent : out Entity_Id; 288 Ofs : out Uint); 289 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check 290 -- to see if a check is of the form for optimization, and if so, to see 291 -- if it has already been performed. Expr is the expression to check, 292 -- and Check_Type is 'R' for a range check, 'O' for an overflow check. 293 -- Target_Type is the target type for a range check, and Empty for an 294 -- overflow check. If the entry is not of the form for optimization, 295 -- then Entry_OK is set to False, and the remaining out parameters 296 -- are undefined. If the entry is OK, then Ent/Ofs are set to the 297 -- entity and offset from the expression. Check_Num is the number of 298 -- a matching saved entry in Saved_Checks, or zero if no such entry 299 -- is located. 300 301 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id; 302 -- If a discriminal is used in constraining a prival, Return reference 303 -- to the discriminal of the protected body (which renames the parameter 304 -- of the enclosing protected operation). This clumsy transformation is 305 -- needed because privals are created too late and their actual subtypes 306 -- are not available when analysing the bodies of the protected operations. 307 -- This function is called whenever the bound is an entity and the scope 308 -- indicates a protected operation. If the bound is an in-parameter of 309 -- a protected operation that is not a prival, the function returns the 310 -- bound itself. 311 -- To be cleaned up??? 312 313 function Guard_Access 314 (Cond : Node_Id; 315 Loc : Source_Ptr; 316 Expr : Node_Id) return Node_Id; 317 -- In the access type case, guard the test with a test to ensure 318 -- that the access value is non-null, since the checks do not 319 -- not apply to null access values. 320 321 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr); 322 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the 323 -- Constraint_Error node. 324 325 function Is_Signed_Integer_Arithmetic_Op (N : Node_Id) return Boolean; 326 -- Returns True if node N is for an arithmetic operation with signed 327 -- integer operands. This includes unary and binary operators, and also 328 -- if and case expression nodes where the dependent expressions are of 329 -- a signed integer type. These are the kinds of nodes for which special 330 -- handling applies in MINIMIZED or ELIMINATED overflow checking mode. 331 332 function Range_Or_Validity_Checks_Suppressed 333 (Expr : Node_Id) return Boolean; 334 -- Returns True if either range or validity checks or both are suppressed 335 -- for the type of the given expression, or, if the expression is the name 336 -- of an entity, if these checks are suppressed for the entity. 337 338 function Selected_Length_Checks 339 (Expr : Node_Id; 340 Target_Typ : Entity_Id; 341 Source_Typ : Entity_Id; 342 Warn_Node : Node_Id) return Check_Result; 343 -- Like Apply_Selected_Length_Checks, except it doesn't modify 344 -- anything, just returns a list of nodes as described in the spec of 345 -- this package for the Range_Check function. 346 -- ??? In fact it does construct the test and insert it into the tree, 347 -- and insert actions in various ways (calling Insert_Action directly 348 -- in particular) so we do not call it in GNATprove mode, contrary to 349 -- Selected_Range_Checks. 350 351 function Selected_Range_Checks 352 (Expr : Node_Id; 353 Target_Typ : Entity_Id; 354 Source_Typ : Entity_Id; 355 Warn_Node : Node_Id) return Check_Result; 356 -- Like Apply_Range_Check, except it does not modify anything, just 357 -- returns a list of nodes as described in the spec of this package 358 -- for the Range_Check function. 359 360 ------------------------------ 361 -- Access_Checks_Suppressed -- 362 ------------------------------ 363 364 function Access_Checks_Suppressed (E : Entity_Id) return Boolean is 365 begin 366 if Present (E) and then Checks_May_Be_Suppressed (E) then 367 return Is_Check_Suppressed (E, Access_Check); 368 else 369 return Scope_Suppress.Suppress (Access_Check); 370 end if; 371 end Access_Checks_Suppressed; 372 373 ------------------------------------- 374 -- Accessibility_Checks_Suppressed -- 375 ------------------------------------- 376 377 function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is 378 begin 379 if Present (E) and then Checks_May_Be_Suppressed (E) then 380 return Is_Check_Suppressed (E, Accessibility_Check); 381 else 382 return Scope_Suppress.Suppress (Accessibility_Check); 383 end if; 384 end Accessibility_Checks_Suppressed; 385 386 ----------------------------- 387 -- Activate_Division_Check -- 388 ----------------------------- 389 390 procedure Activate_Division_Check (N : Node_Id) is 391 begin 392 Set_Do_Division_Check (N, True); 393 Possible_Local_Raise (N, Standard_Constraint_Error); 394 end Activate_Division_Check; 395 396 ----------------------------- 397 -- Activate_Overflow_Check -- 398 ----------------------------- 399 400 procedure Activate_Overflow_Check (N : Node_Id) is 401 Typ : constant Entity_Id := Etype (N); 402 403 begin 404 -- Floating-point case. If Etype is not set (this can happen when we 405 -- activate a check on a node that has not yet been analyzed), then 406 -- we assume we do not have a floating-point type (as per our spec). 407 408 if Present (Typ) and then Is_Floating_Point_Type (Typ) then 409 410 -- Ignore call if we have no automatic overflow checks on the target 411 -- and Check_Float_Overflow mode is not set. These are the cases in 412 -- which we expect to generate infinities and NaN's with no check. 413 414 if not (Machine_Overflows_On_Target or Check_Float_Overflow) then 415 return; 416 417 -- Ignore for unary operations ("+", "-", abs) since these can never 418 -- result in overflow for floating-point cases. 419 420 elsif Nkind (N) in N_Unary_Op then 421 return; 422 423 -- Otherwise we will set the flag 424 425 else 426 null; 427 end if; 428 429 -- Discrete case 430 431 else 432 -- Nothing to do for Rem/Mod/Plus (overflow not possible, the check 433 -- for zero-divide is a divide check, not an overflow check). 434 435 if Nkind (N) in N_Op_Rem | N_Op_Mod | N_Op_Plus then 436 return; 437 end if; 438 end if; 439 440 -- Fall through for cases where we do set the flag 441 442 Set_Do_Overflow_Check (N); 443 Possible_Local_Raise (N, Standard_Constraint_Error); 444 end Activate_Overflow_Check; 445 446 -------------------------- 447 -- Activate_Range_Check -- 448 -------------------------- 449 450 procedure Activate_Range_Check (N : Node_Id) is 451 begin 452 Set_Do_Range_Check (N); 453 Possible_Local_Raise (N, Standard_Constraint_Error); 454 end Activate_Range_Check; 455 456 --------------------------------- 457 -- Alignment_Checks_Suppressed -- 458 --------------------------------- 459 460 function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean is 461 begin 462 if Present (E) and then Checks_May_Be_Suppressed (E) then 463 return Is_Check_Suppressed (E, Alignment_Check); 464 else 465 return Scope_Suppress.Suppress (Alignment_Check); 466 end if; 467 end Alignment_Checks_Suppressed; 468 469 ---------------------------------- 470 -- Allocation_Checks_Suppressed -- 471 ---------------------------------- 472 473 -- Note: at the current time there are no calls to this function, because 474 -- the relevant check is in the run-time, so it is not a check that the 475 -- compiler can suppress anyway, but we still have to recognize the check 476 -- name Allocation_Check since it is part of the standard. 477 478 function Allocation_Checks_Suppressed (E : Entity_Id) return Boolean is 479 begin 480 if Present (E) and then Checks_May_Be_Suppressed (E) then 481 return Is_Check_Suppressed (E, Allocation_Check); 482 else 483 return Scope_Suppress.Suppress (Allocation_Check); 484 end if; 485 end Allocation_Checks_Suppressed; 486 487 ------------------------- 488 -- Append_Range_Checks -- 489 ------------------------- 490 491 procedure Append_Range_Checks 492 (Checks : Check_Result; 493 Stmts : List_Id; 494 Suppress_Typ : Entity_Id; 495 Static_Sloc : Source_Ptr) 496 is 497 Checks_On : constant Boolean := 498 not Index_Checks_Suppressed (Suppress_Typ) 499 or else 500 not Range_Checks_Suppressed (Suppress_Typ); 501 502 begin 503 -- For now we just return if Checks_On is false, however this should be 504 -- enhanced to check for an always True value in the condition and to 505 -- generate a compilation warning??? 506 507 if not Checks_On then 508 return; 509 end if; 510 511 for J in 1 .. 2 loop 512 exit when No (Checks (J)); 513 514 if Nkind (Checks (J)) = N_Raise_Constraint_Error 515 and then Present (Condition (Checks (J))) 516 then 517 Append_To (Stmts, Checks (J)); 518 else 519 Append_To 520 (Stmts, 521 Make_Raise_Constraint_Error (Static_Sloc, 522 Reason => CE_Range_Check_Failed)); 523 end if; 524 end loop; 525 end Append_Range_Checks; 526 527 ------------------------ 528 -- Apply_Access_Check -- 529 ------------------------ 530 531 procedure Apply_Access_Check (N : Node_Id) is 532 P : constant Node_Id := Prefix (N); 533 534 begin 535 -- We do not need checks if we are not generating code (i.e. the 536 -- expander is not active). This is not just an optimization, there 537 -- are cases (e.g. with pragma Debug) where generating the checks 538 -- can cause real trouble. 539 540 if not Expander_Active then 541 return; 542 end if; 543 544 -- No check if short circuiting makes check unnecessary 545 546 if not Check_Needed (P, Access_Check) then 547 return; 548 end if; 549 550 -- No check if accessing the Offset_To_Top component of a dispatch 551 -- table. They are safe by construction. 552 553 if Tagged_Type_Expansion 554 and then Present (Etype (P)) 555 and then RTU_Loaded (Ada_Tags) 556 and then RTE_Available (RE_Offset_To_Top_Ptr) 557 and then Etype (P) = RTE (RE_Offset_To_Top_Ptr) 558 then 559 return; 560 end if; 561 562 -- Otherwise go ahead and install the check 563 564 Install_Null_Excluding_Check (P); 565 end Apply_Access_Check; 566 567 ------------------------------- 568 -- Apply_Accessibility_Check -- 569 ------------------------------- 570 571 procedure Apply_Accessibility_Check 572 (N : Node_Id; 573 Typ : Entity_Id; 574 Insert_Node : Node_Id) 575 is 576 Loc : constant Source_Ptr := Sloc (N); 577 578 Check_Cond : Node_Id; 579 Param_Ent : Entity_Id := Param_Entity (N); 580 Param_Level : Node_Id; 581 Type_Level : Node_Id; 582 583 begin 584 if Ada_Version >= Ada_2012 585 and then not Present (Param_Ent) 586 and then Is_Entity_Name (N) 587 and then Ekind (Entity (N)) in E_Constant | E_Variable 588 and then Present (Effective_Extra_Accessibility (Entity (N))) 589 then 590 Param_Ent := Entity (N); 591 while Present (Renamed_Object (Param_Ent)) loop 592 -- Renamed_Object must return an Entity_Name here 593 -- because of preceding "Present (E_E_A (...))" test. 594 595 Param_Ent := Entity (Renamed_Object (Param_Ent)); 596 end loop; 597 end if; 598 599 if Inside_A_Generic then 600 return; 601 602 -- Only apply the run-time check if the access parameter has an 603 -- associated extra access level parameter and when accessibility checks 604 -- are enabled. 605 606 elsif Present (Param_Ent) 607 and then Present (Get_Dynamic_Accessibility (Param_Ent)) 608 and then not Accessibility_Checks_Suppressed (Param_Ent) 609 and then not Accessibility_Checks_Suppressed (Typ) 610 then 611 -- Obtain the parameter's accessibility level 612 613 Param_Level := 614 New_Occurrence_Of (Get_Dynamic_Accessibility (Param_Ent), Loc); 615 616 -- Use the dynamic accessibility parameter for the function's result 617 -- when one has been created instead of statically referring to the 618 -- deepest type level so as to appropriatly handle the rules for 619 -- RM 3.10.2 (10.1/3). 620 621 if Ekind (Scope (Param_Ent)) = E_Function 622 and then In_Return_Value (N) 623 and then Ekind (Typ) = E_Anonymous_Access_Type 624 then 625 -- Associate the level of the result type to the extra result 626 -- accessibility parameter belonging to the current function. 627 628 if Present (Extra_Accessibility_Of_Result (Scope (Param_Ent))) then 629 Type_Level := 630 New_Occurrence_Of 631 (Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc); 632 633 -- In Ada 2005 and earlier modes, a result extra accessibility 634 -- parameter is not generated and no dynamic check is performed. 635 636 else 637 return; 638 end if; 639 640 -- Otherwise get the type's accessibility level normally 641 642 else 643 Type_Level := 644 Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ)); 645 end if; 646 647 -- Raise Program_Error if the accessibility level of the access 648 -- parameter is deeper than the level of the target access type. 649 650 Check_Cond := 651 Make_Op_Gt (Loc, 652 Left_Opnd => Param_Level, 653 Right_Opnd => Type_Level); 654 655 Insert_Action (Insert_Node, 656 Make_Raise_Program_Error (Loc, 657 Condition => Check_Cond, 658 Reason => PE_Accessibility_Check_Failed)); 659 660 Analyze_And_Resolve (N); 661 662 -- If constant folding has happened on the condition for the 663 -- generated error, then warn about it being unconditional. 664 665 if Nkind (Check_Cond) = N_Identifier 666 and then Entity (Check_Cond) = Standard_True 667 then 668 Error_Msg_Warn := SPARK_Mode /= On; 669 Error_Msg_N ("accessibility check fails<<", N); 670 Error_Msg_N ("\Program_Error [<<", N); 671 end if; 672 end if; 673 end Apply_Accessibility_Check; 674 675 -------------------------------- 676 -- Apply_Address_Clause_Check -- 677 -------------------------------- 678 679 procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id) is 680 pragma Assert (Nkind (N) = N_Freeze_Entity); 681 682 AC : constant Node_Id := Address_Clause (E); 683 Loc : constant Source_Ptr := Sloc (AC); 684 Typ : constant Entity_Id := Etype (E); 685 686 Expr : Node_Id; 687 -- Address expression (not necessarily the same as Aexp, for example 688 -- when Aexp is a reference to a constant, in which case Expr gets 689 -- reset to reference the value expression of the constant). 690 691 begin 692 -- See if alignment check needed. Note that we never need a check if the 693 -- maximum alignment is one, since the check will always succeed. 694 695 -- Note: we do not check for checks suppressed here, since that check 696 -- was done in Sem_Ch13 when the address clause was processed. We are 697 -- only called if checks were not suppressed. The reason for this is 698 -- that we have to delay the call to Apply_Alignment_Check till freeze 699 -- time (so that all types etc are elaborated), but we have to check 700 -- the status of check suppressing at the point of the address clause. 701 702 if No (AC) 703 or else not Check_Address_Alignment (AC) 704 or else Maximum_Alignment = 1 705 then 706 return; 707 end if; 708 709 -- Obtain expression from address clause 710 711 Expr := Address_Value (Expression (AC)); 712 713 -- See if we know that Expr has an acceptable value at compile time. If 714 -- it hasn't or we don't know, we defer issuing the warning until the 715 -- end of the compilation to take into account back end annotations. 716 717 if Compile_Time_Known_Value (Expr) 718 and then (Known_Alignment (E) or else Known_Alignment (Typ)) 719 then 720 declare 721 AL : Uint := Alignment (Typ); 722 723 begin 724 -- The object alignment might be more restrictive than the type 725 -- alignment. 726 727 if Known_Alignment (E) then 728 AL := Alignment (E); 729 end if; 730 731 if Expr_Value (Expr) mod AL = 0 then 732 return; 733 end if; 734 end; 735 736 -- If the expression has the form X'Address, then we can find out if the 737 -- object X has an alignment that is compatible with the object E. If it 738 -- hasn't or we don't know, we defer issuing the warning until the end 739 -- of the compilation to take into account back end annotations. 740 741 elsif Nkind (Expr) = N_Attribute_Reference 742 and then Attribute_Name (Expr) = Name_Address 743 and then 744 Has_Compatible_Alignment (E, Prefix (Expr), False) = Known_Compatible 745 then 746 return; 747 end if; 748 749 -- Here we do not know if the value is acceptable. Strictly we don't 750 -- have to do anything, since if the alignment is bad, we have an 751 -- erroneous program. However we are allowed to check for erroneous 752 -- conditions and we decide to do this by default if the check is not 753 -- suppressed. 754 755 -- However, don't do the check if elaboration code is unwanted 756 757 if Restriction_Active (No_Elaboration_Code) then 758 return; 759 760 -- Generate a check to raise PE if alignment may be inappropriate 761 762 else 763 -- If the original expression is a nonstatic constant, use the name 764 -- of the constant itself rather than duplicating its initialization 765 -- expression, which was extracted above. 766 767 -- Note: Expr is empty if the address-clause is applied to in-mode 768 -- actuals (allowed by 13.1(22)). 769 770 if not Present (Expr) 771 or else 772 (Is_Entity_Name (Expression (AC)) 773 and then Ekind (Entity (Expression (AC))) = E_Constant 774 and then Nkind (Parent (Entity (Expression (AC)))) = 775 N_Object_Declaration) 776 then 777 Expr := New_Copy_Tree (Expression (AC)); 778 else 779 Remove_Side_Effects (Expr); 780 end if; 781 782 if No (Actions (N)) then 783 Set_Actions (N, New_List); 784 end if; 785 786 Prepend_To (Actions (N), 787 Make_Raise_Program_Error (Loc, 788 Condition => 789 Make_Op_Ne (Loc, 790 Left_Opnd => 791 Make_Op_Mod (Loc, 792 Left_Opnd => 793 Unchecked_Convert_To 794 (RTE (RE_Integer_Address), Expr), 795 Right_Opnd => 796 Make_Attribute_Reference (Loc, 797 Prefix => New_Occurrence_Of (E, Loc), 798 Attribute_Name => Name_Alignment)), 799 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), 800 Reason => PE_Misaligned_Address_Value)); 801 802 Warning_Msg := No_Error_Msg; 803 Analyze (First (Actions (N)), Suppress => All_Checks); 804 805 -- If the above raise action generated a warning message (for example 806 -- from Warn_On_Non_Local_Exception mode with the active restriction 807 -- No_Exception_Propagation). 808 809 if Warning_Msg /= No_Error_Msg then 810 811 -- If the expression has a known at compile time value, then 812 -- once we know the alignment of the type, we can check if the 813 -- exception will be raised or not, and if not, we don't need 814 -- the warning so we will kill the warning later on. 815 816 if Compile_Time_Known_Value (Expr) then 817 Alignment_Warnings.Append 818 ((E => E, 819 A => Expr_Value (Expr), 820 P => Empty, 821 W => Warning_Msg)); 822 823 -- Likewise if the expression is of the form X'Address 824 825 elsif Nkind (Expr) = N_Attribute_Reference 826 and then Attribute_Name (Expr) = Name_Address 827 then 828 Alignment_Warnings.Append 829 ((E => E, 830 A => No_Uint, 831 P => Prefix (Expr), 832 W => Warning_Msg)); 833 834 -- Add explanation of the warning generated by the check 835 836 else 837 Error_Msg_N 838 ("\address value may be incompatible with alignment of " 839 & "object?X?", AC); 840 end if; 841 end if; 842 843 return; 844 end if; 845 846 exception 847 848 -- If we have some missing run time component in configurable run time 849 -- mode then just skip the check (it is not required in any case). 850 851 when RE_Not_Available => 852 return; 853 end Apply_Address_Clause_Check; 854 855 ------------------------------------- 856 -- Apply_Arithmetic_Overflow_Check -- 857 ------------------------------------- 858 859 procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is 860 begin 861 -- Use old routine in almost all cases (the only case we are treating 862 -- specially is the case of a signed integer arithmetic op with the 863 -- overflow checking mode set to MINIMIZED or ELIMINATED). 864 865 if Overflow_Check_Mode = Strict 866 or else not Is_Signed_Integer_Arithmetic_Op (N) 867 then 868 Apply_Arithmetic_Overflow_Strict (N); 869 870 -- Otherwise use the new routine for the case of a signed integer 871 -- arithmetic op, with Do_Overflow_Check set to True, and the checking 872 -- mode is MINIMIZED or ELIMINATED. 873 874 else 875 Apply_Arithmetic_Overflow_Minimized_Eliminated (N); 876 end if; 877 end Apply_Arithmetic_Overflow_Check; 878 879 -------------------------------------- 880 -- Apply_Arithmetic_Overflow_Strict -- 881 -------------------------------------- 882 883 -- This routine is called only if the type is an integer type and an 884 -- arithmetic overflow check may be needed for op (add, subtract, or 885 -- multiply). This check is performed if Backend_Overflow_Checks_On_Target 886 -- is not enabled and Do_Overflow_Check is set. In this case we expand the 887 -- operation into a more complex sequence of tests that ensures that 888 -- overflow is properly caught. 889 890 -- This is used in CHECKED modes. It is identical to the code for this 891 -- cases before the big overflow earthquake, thus ensuring that in this 892 -- modes we have compatible behavior (and reliability) to what was there 893 -- before. It is also called for types other than signed integers, and if 894 -- the Do_Overflow_Check flag is off. 895 896 -- Note: we also call this routine if we decide in the MINIMIZED case 897 -- to give up and just generate an overflow check without any fuss. 898 899 procedure Apply_Arithmetic_Overflow_Strict (N : Node_Id) is 900 Loc : constant Source_Ptr := Sloc (N); 901 Typ : constant Entity_Id := Etype (N); 902 Rtyp : constant Entity_Id := Root_Type (Typ); 903 904 begin 905 -- Nothing to do if Do_Overflow_Check not set or overflow checks 906 -- suppressed. 907 908 if not Do_Overflow_Check (N) then 909 return; 910 end if; 911 912 -- An interesting special case. If the arithmetic operation appears as 913 -- the operand of a type conversion: 914 915 -- type1 (x op y) 916 917 -- and all the following conditions apply: 918 919 -- arithmetic operation is for a signed integer type 920 -- target type type1 is a static integer subtype 921 -- range of x and y are both included in the range of type1 922 -- range of x op y is included in the range of type1 923 -- size of type1 is at least twice the result size of op 924 925 -- then we don't do an overflow check in any case. Instead, we transform 926 -- the operation so that we end up with: 927 928 -- type1 (type1 (x) op type1 (y)) 929 930 -- This avoids intermediate overflow before the conversion. It is 931 -- explicitly permitted by RM 3.5.4(24): 932 933 -- For the execution of a predefined operation of a signed integer 934 -- type, the implementation need not raise Constraint_Error if the 935 -- result is outside the base range of the type, so long as the 936 -- correct result is produced. 937 938 -- It's hard to imagine that any programmer counts on the exception 939 -- being raised in this case, and in any case it's wrong coding to 940 -- have this expectation, given the RM permission. Furthermore, other 941 -- Ada compilers do allow such out of range results. 942 943 -- Note that we do this transformation even if overflow checking is 944 -- off, since this is precisely about giving the "right" result and 945 -- avoiding the need for an overflow check. 946 947 -- Note: this circuit is partially redundant with respect to the similar 948 -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals 949 -- with cases that do not come through here. We still need the following 950 -- processing even with the Exp_Ch4 code in place, since we want to be 951 -- sure not to generate the arithmetic overflow check in these cases 952 -- (Exp_Ch4 would have a hard time removing them once generated). 953 954 if Is_Signed_Integer_Type (Typ) 955 and then Nkind (Parent (N)) = N_Type_Conversion 956 then 957 Conversion_Optimization : declare 958 Target_Type : constant Entity_Id := 959 Base_Type (Entity (Subtype_Mark (Parent (N)))); 960 961 Llo, Lhi : Uint; 962 Rlo, Rhi : Uint; 963 LOK, ROK : Boolean; 964 965 Vlo : Uint; 966 Vhi : Uint; 967 VOK : Boolean; 968 969 Tlo : Uint; 970 Thi : Uint; 971 972 begin 973 if Is_Integer_Type (Target_Type) 974 and then RM_Size (Root_Type (Target_Type)) >= 2 * RM_Size (Rtyp) 975 then 976 Tlo := Expr_Value (Type_Low_Bound (Target_Type)); 977 Thi := Expr_Value (Type_High_Bound (Target_Type)); 978 979 Determine_Range 980 (Left_Opnd (N), LOK, Llo, Lhi, Assume_Valid => True); 981 Determine_Range 982 (Right_Opnd (N), ROK, Rlo, Rhi, Assume_Valid => True); 983 984 if (LOK and ROK) 985 and then Tlo <= Llo and then Lhi <= Thi 986 and then Tlo <= Rlo and then Rhi <= Thi 987 then 988 Determine_Range (N, VOK, Vlo, Vhi, Assume_Valid => True); 989 990 if VOK and then Tlo <= Vlo and then Vhi <= Thi then 991 Rewrite (Left_Opnd (N), 992 Make_Type_Conversion (Loc, 993 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), 994 Expression => Relocate_Node (Left_Opnd (N)))); 995 996 Rewrite (Right_Opnd (N), 997 Make_Type_Conversion (Loc, 998 Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), 999 Expression => Relocate_Node (Right_Opnd (N)))); 1000 1001 -- Rewrite the conversion operand so that the original 1002 -- node is retained, in order to avoid the warning for 1003 -- redundant conversions in Resolve_Type_Conversion. 1004 1005 Rewrite (N, Relocate_Node (N)); 1006 1007 Set_Etype (N, Target_Type); 1008 1009 Analyze_And_Resolve (Left_Opnd (N), Target_Type); 1010 Analyze_And_Resolve (Right_Opnd (N), Target_Type); 1011 1012 -- Given that the target type is twice the size of the 1013 -- source type, overflow is now impossible, so we can 1014 -- safely kill the overflow check and return. 1015 1016 Set_Do_Overflow_Check (N, False); 1017 return; 1018 end if; 1019 end if; 1020 end if; 1021 end Conversion_Optimization; 1022 end if; 1023 1024 -- Now see if an overflow check is required 1025 1026 declare 1027 Dsiz : constant Uint := 2 * Esize (Rtyp); 1028 Opnod : Node_Id; 1029 Ctyp : Entity_Id; 1030 Opnd : Node_Id; 1031 Cent : RE_Id; 1032 1033 begin 1034 -- Skip check if back end does overflow checks, or the overflow flag 1035 -- is not set anyway, or we are not doing code expansion, or the 1036 -- parent node is a type conversion whose operand is an arithmetic 1037 -- operation on signed integers on which the expander can promote 1038 -- later the operands to type Integer (see Expand_N_Type_Conversion). 1039 1040 if Backend_Overflow_Checks_On_Target 1041 or else not Do_Overflow_Check (N) 1042 or else not Expander_Active 1043 or else (Present (Parent (N)) 1044 and then Nkind (Parent (N)) = N_Type_Conversion 1045 and then Integer_Promotion_Possible (Parent (N))) 1046 then 1047 return; 1048 end if; 1049 1050 -- Otherwise, generate the full general code for front end overflow 1051 -- detection, which works by doing arithmetic in a larger type: 1052 1053 -- x op y 1054 1055 -- is expanded into 1056 1057 -- Typ (Checktyp (x) op Checktyp (y)); 1058 1059 -- where Typ is the type of the original expression, and Checktyp is 1060 -- an integer type of sufficient length to hold the largest possible 1061 -- result. 1062 1063 -- If the size of the check type exceeds the maximum integer size, 1064 -- we use a different approach, expanding to: 1065 1066 -- typ (xxx_With_Ovflo_Check (Integer_NN (x), Integer_NN (y))) 1067 1068 -- where xxx is Add, Multiply or Subtract as appropriate 1069 1070 -- Find check type if one exists 1071 1072 if Dsiz <= System_Max_Integer_Size then 1073 Ctyp := Integer_Type_For (Dsiz, Uns => False); 1074 1075 -- No check type exists, use runtime call 1076 1077 else 1078 if System_Max_Integer_Size = 64 then 1079 Ctyp := RTE (RE_Integer_64); 1080 else 1081 Ctyp := RTE (RE_Integer_128); 1082 end if; 1083 1084 if Nkind (N) = N_Op_Add then 1085 if System_Max_Integer_Size = 64 then 1086 Cent := RE_Add_With_Ovflo_Check64; 1087 else 1088 Cent := RE_Add_With_Ovflo_Check128; 1089 end if; 1090 1091 elsif Nkind (N) = N_Op_Subtract then 1092 if System_Max_Integer_Size = 64 then 1093 Cent := RE_Subtract_With_Ovflo_Check64; 1094 else 1095 Cent := RE_Subtract_With_Ovflo_Check128; 1096 end if; 1097 1098 else pragma Assert (Nkind (N) = N_Op_Multiply); 1099 if System_Max_Integer_Size = 64 then 1100 Cent := RE_Multiply_With_Ovflo_Check64; 1101 else 1102 Cent := RE_Multiply_With_Ovflo_Check128; 1103 end if; 1104 end if; 1105 1106 Rewrite (N, 1107 OK_Convert_To (Typ, 1108 Make_Function_Call (Loc, 1109 Name => New_Occurrence_Of (RTE (Cent), Loc), 1110 Parameter_Associations => New_List ( 1111 OK_Convert_To (Ctyp, Left_Opnd (N)), 1112 OK_Convert_To (Ctyp, Right_Opnd (N)))))); 1113 1114 Analyze_And_Resolve (N, Typ); 1115 return; 1116 end if; 1117 1118 -- If we fall through, we have the case where we do the arithmetic 1119 -- in the next higher type and get the check by conversion. In these 1120 -- cases Ctyp is set to the type to be used as the check type. 1121 1122 Opnod := Relocate_Node (N); 1123 1124 Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod)); 1125 1126 Analyze (Opnd); 1127 Set_Etype (Opnd, Ctyp); 1128 Set_Analyzed (Opnd, True); 1129 Set_Left_Opnd (Opnod, Opnd); 1130 1131 Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod)); 1132 1133 Analyze (Opnd); 1134 Set_Etype (Opnd, Ctyp); 1135 Set_Analyzed (Opnd, True); 1136 Set_Right_Opnd (Opnod, Opnd); 1137 1138 -- The type of the operation changes to the base type of the check 1139 -- type, and we reset the overflow check indication, since clearly no 1140 -- overflow is possible now that we are using a double length type. 1141 -- We also set the Analyzed flag to avoid a recursive attempt to 1142 -- expand the node. 1143 1144 Set_Etype (Opnod, Base_Type (Ctyp)); 1145 Set_Do_Overflow_Check (Opnod, False); 1146 Set_Analyzed (Opnod, True); 1147 1148 -- Now build the outer conversion 1149 1150 Opnd := OK_Convert_To (Typ, Opnod); 1151 Analyze (Opnd); 1152 Set_Etype (Opnd, Typ); 1153 1154 -- In the discrete type case, we directly generate the range check 1155 -- for the outer operand. This range check will implement the 1156 -- required overflow check. 1157 1158 if Is_Discrete_Type (Typ) then 1159 Rewrite (N, Opnd); 1160 Generate_Range_Check 1161 (Expression (N), Typ, CE_Overflow_Check_Failed); 1162 1163 -- For other types, we enable overflow checking on the conversion, 1164 -- after setting the node as analyzed to prevent recursive attempts 1165 -- to expand the conversion node. 1166 1167 else 1168 Set_Analyzed (Opnd, True); 1169 Enable_Overflow_Check (Opnd); 1170 Rewrite (N, Opnd); 1171 end if; 1172 1173 exception 1174 when RE_Not_Available => 1175 return; 1176 end; 1177 end Apply_Arithmetic_Overflow_Strict; 1178 1179 ---------------------------------------------------- 1180 -- Apply_Arithmetic_Overflow_Minimized_Eliminated -- 1181 ---------------------------------------------------- 1182 1183 procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id) is 1184 pragma Assert (Is_Signed_Integer_Arithmetic_Op (Op)); 1185 1186 Loc : constant Source_Ptr := Sloc (Op); 1187 P : constant Node_Id := Parent (Op); 1188 1189 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer); 1190 -- Operands and results are of this type when we convert 1191 1192 Result_Type : constant Entity_Id := Etype (Op); 1193 -- Original result type 1194 1195 Check_Mode : constant Overflow_Mode_Type := Overflow_Check_Mode; 1196 pragma Assert (Check_Mode in Minimized_Or_Eliminated); 1197 1198 Lo, Hi : Uint; 1199 -- Ranges of values for result 1200 1201 begin 1202 -- Nothing to do if our parent is one of the following: 1203 1204 -- Another signed integer arithmetic op 1205 -- A membership operation 1206 -- A comparison operation 1207 1208 -- In all these cases, we will process at the higher level (and then 1209 -- this node will be processed during the downwards recursion that 1210 -- is part of the processing in Minimize_Eliminate_Overflows). 1211 1212 if Is_Signed_Integer_Arithmetic_Op (P) 1213 or else Nkind (P) in N_Membership_Test 1214 or else Nkind (P) in N_Op_Compare 1215 1216 -- This is also true for an alternative in a case expression 1217 1218 or else Nkind (P) = N_Case_Expression_Alternative 1219 1220 -- This is also true for a range operand in a membership test 1221 1222 or else (Nkind (P) = N_Range 1223 and then Nkind (Parent (P)) in N_Membership_Test) 1224 then 1225 -- If_Expressions and Case_Expressions are treated as arithmetic 1226 -- ops, but if they appear in an assignment or similar contexts 1227 -- there is no overflow check that starts from that parent node, 1228 -- so apply check now. 1229 1230 if Nkind (P) in N_If_Expression | N_Case_Expression 1231 and then not Is_Signed_Integer_Arithmetic_Op (Parent (P)) 1232 then 1233 null; 1234 else 1235 return; 1236 end if; 1237 end if; 1238 1239 -- Otherwise, we have a top level arithmetic operation node, and this 1240 -- is where we commence the special processing for MINIMIZED/ELIMINATED 1241 -- modes. This is the case where we tell the machinery not to move into 1242 -- Bignum mode at this top level (of course the top level operation 1243 -- will still be in Bignum mode if either of its operands are of type 1244 -- Bignum). 1245 1246 Minimize_Eliminate_Overflows (Op, Lo, Hi, Top_Level => True); 1247 1248 -- That call may but does not necessarily change the result type of Op. 1249 -- It is the job of this routine to undo such changes, so that at the 1250 -- top level, we have the proper type. This "undoing" is a point at 1251 -- which a final overflow check may be applied. 1252 1253 -- If the result type was not fiddled we are all set. We go to base 1254 -- types here because things may have been rewritten to generate the 1255 -- base type of the operand types. 1256 1257 if Base_Type (Etype (Op)) = Base_Type (Result_Type) then 1258 return; 1259 1260 -- Bignum case 1261 1262 elsif Is_RTE (Etype (Op), RE_Bignum) then 1263 1264 -- We need a sequence that looks like: 1265 1266 -- Rnn : Result_Type; 1267 1268 -- declare 1269 -- M : Mark_Id := SS_Mark; 1270 -- begin 1271 -- Rnn := Long_Long_Integer'Base (From_Bignum (Op)); 1272 -- SS_Release (M); 1273 -- end; 1274 1275 -- This block is inserted (using Insert_Actions), and then the node 1276 -- is replaced with a reference to Rnn. 1277 1278 -- If our parent is a conversion node then there is no point in 1279 -- generating a conversion to Result_Type. Instead, we let the parent 1280 -- handle this. Note that this special case is not just about 1281 -- optimization. Consider 1282 1283 -- A,B,C : Integer; 1284 -- ... 1285 -- X := Long_Long_Integer'Base (A * (B ** C)); 1286 1287 -- Now the product may fit in Long_Long_Integer but not in Integer. 1288 -- In MINIMIZED/ELIMINATED mode, we don't want to introduce an 1289 -- overflow exception for this intermediate value. 1290 1291 declare 1292 Blk : constant Node_Id := Make_Bignum_Block (Loc); 1293 Rnn : constant Entity_Id := Make_Temporary (Loc, 'R', Op); 1294 RHS : Node_Id; 1295 1296 Rtype : Entity_Id; 1297 1298 begin 1299 RHS := Convert_From_Bignum (Op); 1300 1301 if Nkind (P) /= N_Type_Conversion then 1302 Convert_To_And_Rewrite (Result_Type, RHS); 1303 Rtype := Result_Type; 1304 1305 -- Interesting question, do we need a check on that conversion 1306 -- operation. Answer, not if we know the result is in range. 1307 -- At the moment we are not taking advantage of this. To be 1308 -- looked at later ??? 1309 1310 else 1311 Rtype := LLIB; 1312 end if; 1313 1314 Insert_Before 1315 (First (Statements (Handled_Statement_Sequence (Blk))), 1316 Make_Assignment_Statement (Loc, 1317 Name => New_Occurrence_Of (Rnn, Loc), 1318 Expression => RHS)); 1319 1320 Insert_Actions (Op, New_List ( 1321 Make_Object_Declaration (Loc, 1322 Defining_Identifier => Rnn, 1323 Object_Definition => New_Occurrence_Of (Rtype, Loc)), 1324 Blk)); 1325 1326 Rewrite (Op, New_Occurrence_Of (Rnn, Loc)); 1327 Analyze_And_Resolve (Op); 1328 end; 1329 1330 -- Here we know the result is Long_Long_Integer'Base, or that it has 1331 -- been rewritten because the parent operation is a conversion. See 1332 -- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization. 1333 1334 else 1335 pragma Assert 1336 (Etype (Op) = LLIB or else Nkind (Parent (Op)) = N_Type_Conversion); 1337 1338 -- All we need to do here is to convert the result to the proper 1339 -- result type. As explained above for the Bignum case, we can 1340 -- omit this if our parent is a type conversion. 1341 1342 if Nkind (P) /= N_Type_Conversion then 1343 Convert_To_And_Rewrite (Result_Type, Op); 1344 end if; 1345 1346 Analyze_And_Resolve (Op); 1347 end if; 1348 end Apply_Arithmetic_Overflow_Minimized_Eliminated; 1349 1350 ---------------------------- 1351 -- Apply_Constraint_Check -- 1352 ---------------------------- 1353 1354 procedure Apply_Constraint_Check 1355 (N : Node_Id; 1356 Typ : Entity_Id; 1357 No_Sliding : Boolean := False) 1358 is 1359 Desig_Typ : Entity_Id; 1360 1361 begin 1362 -- No checks inside a generic (check the instantiations) 1363 1364 if Inside_A_Generic then 1365 return; 1366 end if; 1367 1368 -- Apply required constraint checks 1369 1370 if Is_Scalar_Type (Typ) then 1371 Apply_Scalar_Range_Check (N, Typ); 1372 1373 elsif Is_Array_Type (Typ) then 1374 1375 -- A useful optimization: an aggregate with only an others clause 1376 -- always has the right bounds. 1377 1378 if Nkind (N) = N_Aggregate 1379 and then No (Expressions (N)) 1380 and then Nkind 1381 (First (Choices (First (Component_Associations (N))))) 1382 = N_Others_Choice 1383 then 1384 return; 1385 end if; 1386 1387 if Is_Constrained (Typ) then 1388 Apply_Length_Check (N, Typ); 1389 1390 if No_Sliding then 1391 Apply_Range_Check (N, Typ); 1392 end if; 1393 else 1394 Apply_Range_Check (N, Typ); 1395 end if; 1396 1397 elsif (Is_Record_Type (Typ) or else Is_Private_Type (Typ)) 1398 and then Has_Discriminants (Base_Type (Typ)) 1399 and then Is_Constrained (Typ) 1400 then 1401 Apply_Discriminant_Check (N, Typ); 1402 1403 elsif Is_Access_Type (Typ) then 1404 1405 Desig_Typ := Designated_Type (Typ); 1406 1407 -- No checks necessary if expression statically null 1408 1409 if Known_Null (N) then 1410 if Can_Never_Be_Null (Typ) then 1411 Install_Null_Excluding_Check (N); 1412 end if; 1413 1414 -- No sliding possible on access to arrays 1415 1416 elsif Is_Array_Type (Desig_Typ) then 1417 if Is_Constrained (Desig_Typ) then 1418 Apply_Length_Check (N, Typ); 1419 end if; 1420 1421 Apply_Range_Check (N, Typ); 1422 1423 -- Do not install a discriminant check for a constrained subtype 1424 -- created for an unconstrained nominal type because the subtype 1425 -- has the correct constraints by construction. 1426 1427 elsif Has_Discriminants (Base_Type (Desig_Typ)) 1428 and then Is_Constrained (Desig_Typ) 1429 and then not Is_Constr_Subt_For_U_Nominal (Desig_Typ) 1430 then 1431 Apply_Discriminant_Check (N, Typ); 1432 end if; 1433 1434 -- Apply the 2005 Null_Excluding check. Note that we do not apply 1435 -- this check if the constraint node is illegal, as shown by having 1436 -- an error posted. This additional guard prevents cascaded errors 1437 -- and compiler aborts on illegal programs involving Ada 2005 checks. 1438 1439 if Can_Never_Be_Null (Typ) 1440 and then not Can_Never_Be_Null (Etype (N)) 1441 and then not Error_Posted (N) 1442 then 1443 Install_Null_Excluding_Check (N); 1444 end if; 1445 end if; 1446 end Apply_Constraint_Check; 1447 1448 ------------------------------ 1449 -- Apply_Discriminant_Check -- 1450 ------------------------------ 1451 1452 procedure Apply_Discriminant_Check 1453 (N : Node_Id; 1454 Typ : Entity_Id; 1455 Lhs : Node_Id := Empty) 1456 is 1457 Loc : constant Source_Ptr := Sloc (N); 1458 Do_Access : constant Boolean := Is_Access_Type (Typ); 1459 S_Typ : Entity_Id := Etype (N); 1460 Cond : Node_Id; 1461 T_Typ : Entity_Id; 1462 1463 function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean; 1464 -- A heap object with an indefinite subtype is constrained by its 1465 -- initial value, and assigning to it requires a constraint_check. 1466 -- The target may be an explicit dereference, or a renaming of one. 1467 1468 function Is_Aliased_Unconstrained_Component return Boolean; 1469 -- It is possible for an aliased component to have a nominal 1470 -- unconstrained subtype (through instantiation). If this is a 1471 -- discriminated component assigned in the expansion of an aggregate 1472 -- in an initialization, the check must be suppressed. This unusual 1473 -- situation requires a predicate of its own. 1474 1475 ---------------------------------- 1476 -- Denotes_Explicit_Dereference -- 1477 ---------------------------------- 1478 1479 function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean is 1480 begin 1481 return 1482 Nkind (Obj) = N_Explicit_Dereference 1483 or else 1484 (Is_Entity_Name (Obj) 1485 and then Present (Renamed_Object (Entity (Obj))) 1486 and then Nkind (Renamed_Object (Entity (Obj))) = 1487 N_Explicit_Dereference); 1488 end Denotes_Explicit_Dereference; 1489 1490 ---------------------------------------- 1491 -- Is_Aliased_Unconstrained_Component -- 1492 ---------------------------------------- 1493 1494 function Is_Aliased_Unconstrained_Component return Boolean is 1495 Comp : Entity_Id; 1496 Pref : Node_Id; 1497 1498 begin 1499 if Nkind (Lhs) /= N_Selected_Component then 1500 return False; 1501 else 1502 Comp := Entity (Selector_Name (Lhs)); 1503 Pref := Prefix (Lhs); 1504 end if; 1505 1506 if Ekind (Comp) /= E_Component 1507 or else not Is_Aliased (Comp) 1508 then 1509 return False; 1510 end if; 1511 1512 return not Comes_From_Source (Pref) 1513 and then In_Instance 1514 and then not Is_Constrained (Etype (Comp)); 1515 end Is_Aliased_Unconstrained_Component; 1516 1517 -- Start of processing for Apply_Discriminant_Check 1518 1519 begin 1520 if Do_Access then 1521 T_Typ := Designated_Type (Typ); 1522 else 1523 T_Typ := Typ; 1524 end if; 1525 1526 -- If the expression is a function call that returns a limited object 1527 -- it cannot be copied. It is not clear how to perform the proper 1528 -- discriminant check in this case because the discriminant value must 1529 -- be retrieved from the constructed object itself. 1530 1531 if Nkind (N) = N_Function_Call 1532 and then Is_Limited_Type (Typ) 1533 and then Is_Entity_Name (Name (N)) 1534 and then Returns_By_Ref (Entity (Name (N))) 1535 then 1536 return; 1537 end if; 1538 1539 -- Only apply checks when generating code and discriminant checks are 1540 -- not suppressed. In GNATprove mode, we do not apply the checks, but we 1541 -- still analyze the expression to possibly issue errors on SPARK code 1542 -- when a run-time error can be detected at compile time. 1543 1544 if not GNATprove_Mode then 1545 if not Expander_Active 1546 or else Discriminant_Checks_Suppressed (T_Typ) 1547 then 1548 return; 1549 end if; 1550 end if; 1551 1552 -- No discriminant checks necessary for an access when expression is 1553 -- statically Null. This is not only an optimization, it is fundamental 1554 -- because otherwise discriminant checks may be generated in init procs 1555 -- for types containing an access to a not-yet-frozen record, causing a 1556 -- deadly forward reference. 1557 1558 -- Also, if the expression is of an access type whose designated type is 1559 -- incomplete, then the access value must be null and we suppress the 1560 -- check. 1561 1562 if Known_Null (N) then 1563 return; 1564 1565 elsif Is_Access_Type (S_Typ) then 1566 S_Typ := Designated_Type (S_Typ); 1567 1568 if Ekind (S_Typ) = E_Incomplete_Type then 1569 return; 1570 end if; 1571 end if; 1572 1573 -- If an assignment target is present, then we need to generate the 1574 -- actual subtype if the target is a parameter or aliased object with 1575 -- an unconstrained nominal subtype. 1576 1577 -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual 1578 -- subtype to the parameter and dereference cases, since other aliased 1579 -- objects are unconstrained (unless the nominal subtype is explicitly 1580 -- constrained). 1581 1582 if Present (Lhs) 1583 and then (Present (Param_Entity (Lhs)) 1584 or else (Ada_Version < Ada_2005 1585 and then not Is_Constrained (T_Typ) 1586 and then Is_Aliased_View (Lhs) 1587 and then not Is_Aliased_Unconstrained_Component) 1588 or else (Ada_Version >= Ada_2005 1589 and then not Is_Constrained (T_Typ) 1590 and then Denotes_Explicit_Dereference (Lhs) 1591 and then Nkind (Original_Node (Lhs)) /= 1592 N_Function_Call)) 1593 then 1594 T_Typ := Get_Actual_Subtype (Lhs); 1595 end if; 1596 1597 -- Nothing to do if the type is unconstrained (this is the case where 1598 -- the actual subtype in the RM sense of N is unconstrained and no check 1599 -- is required). 1600 1601 if not Is_Constrained (T_Typ) then 1602 return; 1603 1604 -- Ada 2005: nothing to do if the type is one for which there is a 1605 -- partial view that is constrained. 1606 1607 elsif Ada_Version >= Ada_2005 1608 and then Object_Type_Has_Constrained_Partial_View 1609 (Typ => Base_Type (T_Typ), 1610 Scop => Current_Scope) 1611 then 1612 return; 1613 end if; 1614 1615 -- Nothing to do if the type is an Unchecked_Union 1616 1617 if Is_Unchecked_Union (Base_Type (T_Typ)) then 1618 return; 1619 end if; 1620 1621 -- Suppress checks if the subtypes are the same. The check must be 1622 -- preserved in an assignment to a formal, because the constraint is 1623 -- given by the actual. 1624 1625 if Nkind (Original_Node (N)) /= N_Allocator 1626 and then (No (Lhs) 1627 or else not Is_Entity_Name (Lhs) 1628 or else No (Param_Entity (Lhs))) 1629 then 1630 if (Etype (N) = Typ 1631 or else (Do_Access and then Designated_Type (Typ) = S_Typ)) 1632 and then not Is_Aliased_View (Lhs) 1633 then 1634 return; 1635 end if; 1636 1637 -- We can also eliminate checks on allocators with a subtype mark that 1638 -- coincides with the context type. The context type may be a subtype 1639 -- without a constraint (common case, a generic actual). 1640 1641 elsif Nkind (Original_Node (N)) = N_Allocator 1642 and then Is_Entity_Name (Expression (Original_Node (N))) 1643 then 1644 declare 1645 Alloc_Typ : constant Entity_Id := 1646 Entity (Expression (Original_Node (N))); 1647 1648 begin 1649 if Alloc_Typ = T_Typ 1650 or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration 1651 and then Is_Entity_Name ( 1652 Subtype_Indication (Parent (T_Typ))) 1653 and then Alloc_Typ = Base_Type (T_Typ)) 1654 1655 then 1656 return; 1657 end if; 1658 end; 1659 end if; 1660 1661 -- See if we have a case where the types are both constrained, and all 1662 -- the constraints are constants. In this case, we can do the check 1663 -- successfully at compile time. 1664 1665 -- We skip this check for the case where the node is rewritten as 1666 -- an allocator, because it already carries the context subtype, 1667 -- and extracting the discriminants from the aggregate is messy. 1668 1669 if Is_Constrained (S_Typ) 1670 and then Nkind (Original_Node (N)) /= N_Allocator 1671 then 1672 declare 1673 DconT : Elmt_Id; 1674 Discr : Entity_Id; 1675 DconS : Elmt_Id; 1676 ItemS : Node_Id; 1677 ItemT : Node_Id; 1678 1679 begin 1680 -- S_Typ may not have discriminants in the case where it is a 1681 -- private type completed by a default discriminated type. In that 1682 -- case, we need to get the constraints from the underlying type. 1683 -- If the underlying type is unconstrained (i.e. has no default 1684 -- discriminants) no check is needed. 1685 1686 if Has_Discriminants (S_Typ) then 1687 Discr := First_Discriminant (S_Typ); 1688 DconS := First_Elmt (Discriminant_Constraint (S_Typ)); 1689 1690 else 1691 Discr := First_Discriminant (Underlying_Type (S_Typ)); 1692 DconS := 1693 First_Elmt 1694 (Discriminant_Constraint (Underlying_Type (S_Typ))); 1695 1696 if No (DconS) then 1697 return; 1698 end if; 1699 1700 -- A further optimization: if T_Typ is derived from S_Typ 1701 -- without imposing a constraint, no check is needed. 1702 1703 if Nkind (Original_Node (Parent (T_Typ))) = 1704 N_Full_Type_Declaration 1705 then 1706 declare 1707 Type_Def : constant Node_Id := 1708 Type_Definition (Original_Node (Parent (T_Typ))); 1709 begin 1710 if Nkind (Type_Def) = N_Derived_Type_Definition 1711 and then Is_Entity_Name (Subtype_Indication (Type_Def)) 1712 and then Entity (Subtype_Indication (Type_Def)) = S_Typ 1713 then 1714 return; 1715 end if; 1716 end; 1717 end if; 1718 end if; 1719 1720 -- Constraint may appear in full view of type 1721 1722 if Ekind (T_Typ) = E_Private_Subtype 1723 and then Present (Full_View (T_Typ)) 1724 then 1725 DconT := 1726 First_Elmt (Discriminant_Constraint (Full_View (T_Typ))); 1727 else 1728 DconT := 1729 First_Elmt (Discriminant_Constraint (T_Typ)); 1730 end if; 1731 1732 while Present (Discr) loop 1733 ItemS := Node (DconS); 1734 ItemT := Node (DconT); 1735 1736 -- For a discriminated component type constrained by the 1737 -- current instance of an enclosing type, there is no 1738 -- applicable discriminant check. 1739 1740 if Nkind (ItemT) = N_Attribute_Reference 1741 and then Is_Access_Type (Etype (ItemT)) 1742 and then Is_Entity_Name (Prefix (ItemT)) 1743 and then Is_Type (Entity (Prefix (ItemT))) 1744 then 1745 return; 1746 end if; 1747 1748 -- If the expressions for the discriminants are identical 1749 -- and it is side-effect free (for now just an entity), 1750 -- this may be a shared constraint, e.g. from a subtype 1751 -- without a constraint introduced as a generic actual. 1752 -- Examine other discriminants if any. 1753 1754 if ItemS = ItemT 1755 and then Is_Entity_Name (ItemS) 1756 then 1757 null; 1758 1759 elsif not Is_OK_Static_Expression (ItemS) 1760 or else not Is_OK_Static_Expression (ItemT) 1761 then 1762 exit; 1763 1764 elsif Expr_Value (ItemS) /= Expr_Value (ItemT) then 1765 if Do_Access then -- needs run-time check. 1766 exit; 1767 else 1768 Apply_Compile_Time_Constraint_Error 1769 (N, "incorrect value for discriminant&??", 1770 CE_Discriminant_Check_Failed, Ent => Discr); 1771 return; 1772 end if; 1773 end if; 1774 1775 Next_Elmt (DconS); 1776 Next_Elmt (DconT); 1777 Next_Discriminant (Discr); 1778 end loop; 1779 1780 if No (Discr) then 1781 return; 1782 end if; 1783 end; 1784 end if; 1785 1786 -- In GNATprove mode, we do not apply the checks 1787 1788 if GNATprove_Mode then 1789 return; 1790 end if; 1791 1792 -- Here we need a discriminant check. First build the expression 1793 -- for the comparisons of the discriminants: 1794 1795 -- (n.disc1 /= typ.disc1) or else 1796 -- (n.disc2 /= typ.disc2) or else 1797 -- ... 1798 -- (n.discn /= typ.discn) 1799 1800 Cond := Build_Discriminant_Checks (N, T_Typ); 1801 1802 -- If Lhs is set and is a parameter, then the condition is guarded by: 1803 -- lhs'constrained and then (condition built above) 1804 1805 if Present (Param_Entity (Lhs)) then 1806 Cond := 1807 Make_And_Then (Loc, 1808 Left_Opnd => 1809 Make_Attribute_Reference (Loc, 1810 Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc), 1811 Attribute_Name => Name_Constrained), 1812 Right_Opnd => Cond); 1813 end if; 1814 1815 if Do_Access then 1816 Cond := Guard_Access (Cond, Loc, N); 1817 end if; 1818 1819 Insert_Action (N, 1820 Make_Raise_Constraint_Error (Loc, 1821 Condition => Cond, 1822 Reason => CE_Discriminant_Check_Failed)); 1823 end Apply_Discriminant_Check; 1824 1825 ------------------------- 1826 -- Apply_Divide_Checks -- 1827 ------------------------- 1828 1829 procedure Apply_Divide_Checks (N : Node_Id) is 1830 Loc : constant Source_Ptr := Sloc (N); 1831 Typ : constant Entity_Id := Etype (N); 1832 Left : constant Node_Id := Left_Opnd (N); 1833 Right : constant Node_Id := Right_Opnd (N); 1834 1835 Mode : constant Overflow_Mode_Type := Overflow_Check_Mode; 1836 -- Current overflow checking mode 1837 1838 LLB : Uint; 1839 Llo : Uint; 1840 Lhi : Uint; 1841 LOK : Boolean; 1842 Rlo : Uint; 1843 Rhi : Uint; 1844 ROK : Boolean; 1845 1846 pragma Warnings (Off, Lhi); 1847 -- Don't actually use this value 1848 1849 begin 1850 -- If we are operating in MINIMIZED or ELIMINATED mode, and we are 1851 -- operating on signed integer types, then the only thing this routine 1852 -- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That 1853 -- procedure will (possibly later on during recursive downward calls), 1854 -- ensure that any needed overflow/division checks are properly applied. 1855 1856 if Mode in Minimized_Or_Eliminated 1857 and then Is_Signed_Integer_Type (Typ) 1858 then 1859 Apply_Arithmetic_Overflow_Minimized_Eliminated (N); 1860 return; 1861 end if; 1862 1863 -- Proceed here in SUPPRESSED or CHECKED modes 1864 1865 if Expander_Active 1866 and then not Backend_Divide_Checks_On_Target 1867 and then Check_Needed (Right, Division_Check) 1868 then 1869 Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True); 1870 1871 -- Deal with division check 1872 1873 if Do_Division_Check (N) 1874 and then not Division_Checks_Suppressed (Typ) 1875 then 1876 Apply_Division_Check (N, Rlo, Rhi, ROK); 1877 end if; 1878 1879 -- Deal with overflow check 1880 1881 if Do_Overflow_Check (N) 1882 and then not Overflow_Checks_Suppressed (Etype (N)) 1883 then 1884 Set_Do_Overflow_Check (N, False); 1885 1886 -- Test for extremely annoying case of xxx'First divided by -1 1887 -- for division of signed integer types (only overflow case). 1888 1889 if Nkind (N) = N_Op_Divide 1890 and then Is_Signed_Integer_Type (Typ) 1891 then 1892 Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True); 1893 LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ))); 1894 1895 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) 1896 and then 1897 ((not LOK) or else (Llo = LLB)) 1898 then 1899 -- Ensure that expressions are not evaluated twice (once 1900 -- for their runtime checks and once for their regular 1901 -- computation). 1902 1903 Force_Evaluation (Left, Mode => Strict); 1904 Force_Evaluation (Right, Mode => Strict); 1905 1906 Insert_Action (N, 1907 Make_Raise_Constraint_Error (Loc, 1908 Condition => 1909 Make_And_Then (Loc, 1910 Left_Opnd => 1911 Make_Op_Eq (Loc, 1912 Left_Opnd => 1913 Duplicate_Subexpr_Move_Checks (Left), 1914 Right_Opnd => Make_Integer_Literal (Loc, LLB)), 1915 1916 Right_Opnd => 1917 Make_Op_Eq (Loc, 1918 Left_Opnd => Duplicate_Subexpr (Right), 1919 Right_Opnd => Make_Integer_Literal (Loc, -1))), 1920 1921 Reason => CE_Overflow_Check_Failed)); 1922 end if; 1923 end if; 1924 end if; 1925 end if; 1926 end Apply_Divide_Checks; 1927 1928 -------------------------- 1929 -- Apply_Division_Check -- 1930 -------------------------- 1931 1932 procedure Apply_Division_Check 1933 (N : Node_Id; 1934 Rlo : Uint; 1935 Rhi : Uint; 1936 ROK : Boolean) 1937 is 1938 pragma Assert (Do_Division_Check (N)); 1939 1940 Loc : constant Source_Ptr := Sloc (N); 1941 Right : constant Node_Id := Right_Opnd (N); 1942 Opnd : Node_Id; 1943 1944 begin 1945 if Expander_Active 1946 and then not Backend_Divide_Checks_On_Target 1947 and then Check_Needed (Right, Division_Check) 1948 1949 -- See if division by zero possible, and if so generate test. This 1950 -- part of the test is not controlled by the -gnato switch, since it 1951 -- is a Division_Check and not an Overflow_Check. 1952 1953 and then Do_Division_Check (N) 1954 then 1955 Set_Do_Division_Check (N, False); 1956 1957 if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then 1958 if Is_Floating_Point_Type (Etype (N)) then 1959 Opnd := Make_Real_Literal (Loc, Ureal_0); 1960 else 1961 Opnd := Make_Integer_Literal (Loc, 0); 1962 end if; 1963 1964 Insert_Action (N, 1965 Make_Raise_Constraint_Error (Loc, 1966 Condition => 1967 Make_Op_Eq (Loc, 1968 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right), 1969 Right_Opnd => Opnd), 1970 Reason => CE_Divide_By_Zero)); 1971 end if; 1972 end if; 1973 end Apply_Division_Check; 1974 1975 ---------------------------------- 1976 -- Apply_Float_Conversion_Check -- 1977 ---------------------------------- 1978 1979 -- Let F and I be the source and target types of the conversion. The RM 1980 -- specifies that a floating-point value X is rounded to the nearest 1981 -- integer, with halfway cases being rounded away from zero. The rounded 1982 -- value of X is checked against I'Range. 1983 1984 -- The catch in the above paragraph is that there is no good way to know 1985 -- whether the round-to-integer operation resulted in overflow. A remedy is 1986 -- to perform a range check in the floating-point domain instead, however: 1987 1988 -- (1) The bounds may not be known at compile time 1989 -- (2) The check must take into account rounding or truncation. 1990 -- (3) The range of type I may not be exactly representable in F. 1991 -- (4) For the rounding case, the end-points I'First - 0.5 and 1992 -- I'Last + 0.5 may or may not be in range, depending on the 1993 -- sign of I'First and I'Last. 1994 -- (5) X may be a NaN, which will fail any comparison 1995 1996 -- The following steps correctly convert X with rounding: 1997 1998 -- (1) If either I'First or I'Last is not known at compile time, use 1999 -- I'Base instead of I in the next three steps and perform a 2000 -- regular range check against I'Range after conversion. 2001 -- (2) If I'First - 0.5 is representable in F then let Lo be that 2002 -- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be 2003 -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First). 2004 -- In other words, take one of the closest floating-point numbers 2005 -- (which is an integer value) to I'First, and see if it is in 2006 -- range or not. 2007 -- (3) If I'Last + 0.5 is representable in F then let Hi be that value 2008 -- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be 2009 -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last). 2010 -- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo) 2011 -- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi) 2012 2013 -- For the truncating case, replace steps (2) and (3) as follows: 2014 -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK 2015 -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let 2016 -- Lo_OK be True. 2017 -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK 2018 -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let 2019 -- Hi_OK be True. 2020 2021 procedure Apply_Float_Conversion_Check 2022 (Expr : Node_Id; 2023 Target_Typ : Entity_Id) 2024 is 2025 LB : constant Node_Id := Type_Low_Bound (Target_Typ); 2026 HB : constant Node_Id := Type_High_Bound (Target_Typ); 2027 Loc : constant Source_Ptr := Sloc (Expr); 2028 Expr_Type : constant Entity_Id := Base_Type (Etype (Expr)); 2029 Target_Base : constant Entity_Id := 2030 Implementation_Base_Type (Target_Typ); 2031 2032 Par : constant Node_Id := Parent (Expr); 2033 pragma Assert (Nkind (Par) = N_Type_Conversion); 2034 -- Parent of check node, must be a type conversion 2035 2036 Truncate : constant Boolean := Float_Truncate (Par); 2037 Max_Bound : constant Uint := 2038 UI_Expon 2039 (Machine_Radix_Value (Expr_Type), 2040 Machine_Mantissa_Value (Expr_Type) - 1) - 1; 2041 2042 -- Largest bound, so bound plus or minus half is a machine number of F 2043 2044 Ifirst, Ilast : Uint; 2045 -- Bounds of integer type 2046 2047 Lo, Hi : Ureal; 2048 -- Bounds to check in floating-point domain 2049 2050 Lo_OK, Hi_OK : Boolean; 2051 -- True iff Lo resp. Hi belongs to I'Range 2052 2053 Lo_Chk, Hi_Chk : Node_Id; 2054 -- Expressions that are False iff check fails 2055 2056 Reason : RT_Exception_Code; 2057 2058 begin 2059 -- We do not need checks if we are not generating code (i.e. the full 2060 -- expander is not active). In SPARK mode, we specifically don't want 2061 -- the frontend to expand these checks, which are dealt with directly 2062 -- in the formal verification backend. 2063 2064 if not Expander_Active then 2065 return; 2066 end if; 2067 2068 -- Here we will generate an explicit range check, so we don't want to 2069 -- set the Do_Range check flag, since the range check is taken care of 2070 -- by the code we will generate. 2071 2072 Set_Do_Range_Check (Expr, False); 2073 2074 if not Compile_Time_Known_Value (LB) 2075 or not Compile_Time_Known_Value (HB) 2076 then 2077 declare 2078 -- First check that the value falls in the range of the base type, 2079 -- to prevent overflow during conversion and then perform a 2080 -- regular range check against the (dynamic) bounds. 2081 2082 pragma Assert (Target_Base /= Target_Typ); 2083 2084 Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Par); 2085 2086 begin 2087 Apply_Float_Conversion_Check (Expr, Target_Base); 2088 Set_Etype (Temp, Target_Base); 2089 2090 -- Note: Previously the declaration was inserted above the parent 2091 -- of the conversion, apparently as a small optimization for the 2092 -- subequent traversal in Insert_Actions. Unfortunately a similar 2093 -- optimization takes place in Insert_Actions, assuming that the 2094 -- insertion point must be above the expression that creates 2095 -- actions. This is not correct in the presence of conditional 2096 -- expressions, where the insertion must be in the list of actions 2097 -- attached to the current alternative. 2098 2099 Insert_Action (Par, 2100 Make_Object_Declaration (Loc, 2101 Defining_Identifier => Temp, 2102 Object_Definition => New_Occurrence_Of (Target_Typ, Loc), 2103 Expression => New_Copy_Tree (Par)), 2104 Suppress => All_Checks); 2105 2106 Insert_Action (Par, 2107 Make_Raise_Constraint_Error (Loc, 2108 Condition => 2109 Make_Not_In (Loc, 2110 Left_Opnd => New_Occurrence_Of (Temp, Loc), 2111 Right_Opnd => New_Occurrence_Of (Target_Typ, Loc)), 2112 Reason => CE_Range_Check_Failed)); 2113 Rewrite (Par, New_Occurrence_Of (Temp, Loc)); 2114 2115 return; 2116 end; 2117 end if; 2118 2119 -- Get the (static) bounds of the target type 2120 2121 Ifirst := Expr_Value (LB); 2122 Ilast := Expr_Value (HB); 2123 2124 -- A simple optimization: if the expression is a universal literal, 2125 -- we can do the comparison with the bounds and the conversion to 2126 -- an integer type statically. The range checks are unchanged. 2127 2128 if Nkind (Expr) = N_Real_Literal 2129 and then Etype (Expr) = Universal_Real 2130 and then Is_Integer_Type (Target_Typ) 2131 then 2132 declare 2133 Int_Val : constant Uint := UR_To_Uint (Realval (Expr)); 2134 2135 begin 2136 if Int_Val <= Ilast and then Int_Val >= Ifirst then 2137 2138 -- Conversion is safe 2139 2140 Rewrite (Parent (Expr), 2141 Make_Integer_Literal (Loc, UI_To_Int (Int_Val))); 2142 Analyze_And_Resolve (Parent (Expr), Target_Typ); 2143 return; 2144 end if; 2145 end; 2146 end if; 2147 2148 -- Check against lower bound 2149 2150 if Truncate and then Ifirst > 0 then 2151 Lo := Pred (Expr_Type, UR_From_Uint (Ifirst)); 2152 Lo_OK := False; 2153 2154 elsif Truncate then 2155 Lo := Succ (Expr_Type, UR_From_Uint (Ifirst - 1)); 2156 Lo_OK := True; 2157 2158 elsif abs (Ifirst) < Max_Bound then 2159 Lo := UR_From_Uint (Ifirst) - Ureal_Half; 2160 Lo_OK := (Ifirst > 0); 2161 2162 else 2163 Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Expr); 2164 Lo_OK := (Lo >= UR_From_Uint (Ifirst)); 2165 end if; 2166 2167 -- Saturate the lower bound to that of the expression's type, because 2168 -- we do not want to create an out-of-range value but we still need to 2169 -- do a comparison to catch NaNs. 2170 2171 if Lo < Expr_Value_R (Type_Low_Bound (Expr_Type)) then 2172 Lo := Expr_Value_R (Type_Low_Bound (Expr_Type)); 2173 Lo_OK := True; 2174 end if; 2175 2176 if Lo_OK then 2177 2178 -- Lo_Chk := (X >= Lo) 2179 2180 Lo_Chk := Make_Op_Ge (Loc, 2181 Left_Opnd => Duplicate_Subexpr_No_Checks (Expr), 2182 Right_Opnd => Make_Real_Literal (Loc, Lo)); 2183 2184 else 2185 -- Lo_Chk := (X > Lo) 2186 2187 Lo_Chk := Make_Op_Gt (Loc, 2188 Left_Opnd => Duplicate_Subexpr_No_Checks (Expr), 2189 Right_Opnd => Make_Real_Literal (Loc, Lo)); 2190 end if; 2191 2192 -- Check against higher bound 2193 2194 if Truncate and then Ilast < 0 then 2195 Hi := Succ (Expr_Type, UR_From_Uint (Ilast)); 2196 Hi_OK := False; 2197 2198 elsif Truncate then 2199 Hi := Pred (Expr_Type, UR_From_Uint (Ilast + 1)); 2200 Hi_OK := True; 2201 2202 elsif abs (Ilast) < Max_Bound then 2203 Hi := UR_From_Uint (Ilast) + Ureal_Half; 2204 Hi_OK := (Ilast < 0); 2205 else 2206 Hi := Machine (Expr_Type, UR_From_Uint (Ilast), Round_Even, Expr); 2207 Hi_OK := (Hi <= UR_From_Uint (Ilast)); 2208 end if; 2209 2210 -- Saturate the higher bound to that of the expression's type, because 2211 -- we do not want to create an out-of-range value but we still need to 2212 -- do a comparison to catch NaNs. 2213 2214 if Hi > Expr_Value_R (Type_High_Bound (Expr_Type)) then 2215 Hi := Expr_Value_R (Type_High_Bound (Expr_Type)); 2216 Hi_OK := True; 2217 end if; 2218 2219 if Hi_OK then 2220 2221 -- Hi_Chk := (X <= Hi) 2222 2223 Hi_Chk := Make_Op_Le (Loc, 2224 Left_Opnd => Duplicate_Subexpr_No_Checks (Expr), 2225 Right_Opnd => Make_Real_Literal (Loc, Hi)); 2226 2227 else 2228 -- Hi_Chk := (X < Hi) 2229 2230 Hi_Chk := Make_Op_Lt (Loc, 2231 Left_Opnd => Duplicate_Subexpr_No_Checks (Expr), 2232 Right_Opnd => Make_Real_Literal (Loc, Hi)); 2233 end if; 2234 2235 -- If the bounds of the target type are the same as those of the base 2236 -- type, the check is an overflow check as a range check is not 2237 -- performed in these cases. 2238 2239 if Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst 2240 and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast 2241 then 2242 Reason := CE_Overflow_Check_Failed; 2243 else 2244 Reason := CE_Range_Check_Failed; 2245 end if; 2246 2247 -- Raise CE if either conditions does not hold 2248 2249 Insert_Action (Expr, 2250 Make_Raise_Constraint_Error (Loc, 2251 Condition => Make_Op_Not (Loc, Make_And_Then (Loc, Lo_Chk, Hi_Chk)), 2252 Reason => Reason)); 2253 end Apply_Float_Conversion_Check; 2254 2255 ------------------------ 2256 -- Apply_Length_Check -- 2257 ------------------------ 2258 2259 procedure Apply_Length_Check 2260 (Expr : Node_Id; 2261 Target_Typ : Entity_Id; 2262 Source_Typ : Entity_Id := Empty) 2263 is 2264 begin 2265 Apply_Selected_Length_Checks 2266 (Expr, Target_Typ, Source_Typ, Do_Static => False); 2267 end Apply_Length_Check; 2268 2269 -------------------------------------- 2270 -- Apply_Length_Check_On_Assignment -- 2271 -------------------------------------- 2272 2273 procedure Apply_Length_Check_On_Assignment 2274 (Expr : Node_Id; 2275 Target_Typ : Entity_Id; 2276 Target : Node_Id; 2277 Source_Typ : Entity_Id := Empty) 2278 is 2279 Assign : constant Node_Id := Parent (Target); 2280 2281 begin 2282 -- No check is needed for the initialization of an object whose 2283 -- nominal subtype is unconstrained. 2284 2285 if Is_Constr_Subt_For_U_Nominal (Target_Typ) 2286 and then Nkind (Parent (Assign)) = N_Freeze_Entity 2287 and then Is_Entity_Name (Target) 2288 and then Entity (Target) = Entity (Parent (Assign)) 2289 then 2290 return; 2291 end if; 2292 2293 Apply_Selected_Length_Checks 2294 (Expr, Target_Typ, Source_Typ, Do_Static => False); 2295 end Apply_Length_Check_On_Assignment; 2296 2297 ------------------------------------- 2298 -- Apply_Parameter_Aliasing_Checks -- 2299 ------------------------------------- 2300 2301 procedure Apply_Parameter_Aliasing_Checks 2302 (Call : Node_Id; 2303 Subp : Entity_Id) 2304 is 2305 Loc : constant Source_Ptr := Sloc (Call); 2306 2307 function May_Cause_Aliasing 2308 (Formal_1 : Entity_Id; 2309 Formal_2 : Entity_Id) return Boolean; 2310 -- Determine whether two formal parameters can alias each other 2311 -- depending on their modes. 2312 2313 function Original_Actual (N : Node_Id) return Node_Id; 2314 -- The expander may replace an actual with a temporary for the sake of 2315 -- side effect removal. The temporary may hide a potential aliasing as 2316 -- it does not share the address of the actual. This routine attempts 2317 -- to retrieve the original actual. 2318 2319 procedure Overlap_Check 2320 (Actual_1 : Node_Id; 2321 Actual_2 : Node_Id; 2322 Formal_1 : Entity_Id; 2323 Formal_2 : Entity_Id; 2324 Check : in out Node_Id); 2325 -- Create a check to determine whether Actual_1 overlaps with Actual_2. 2326 -- If detailed exception messages are enabled, the check is augmented to 2327 -- provide information about the names of the corresponding formals. See 2328 -- the body for details. Actual_1 and Actual_2 denote the two actuals to 2329 -- be tested. Formal_1 and Formal_2 denote the corresponding formals. 2330 -- Check contains all and-ed simple tests generated so far or remains 2331 -- unchanged in the case of detailed exception messaged. 2332 2333 ------------------------ 2334 -- May_Cause_Aliasing -- 2335 ------------------------ 2336 2337 function May_Cause_Aliasing 2338 (Formal_1 : Entity_Id; 2339 Formal_2 : Entity_Id) return Boolean 2340 is 2341 begin 2342 -- The following combination cannot lead to aliasing 2343 2344 -- Formal 1 Formal 2 2345 -- IN IN 2346 2347 if Ekind (Formal_1) = E_In_Parameter 2348 and then 2349 Ekind (Formal_2) = E_In_Parameter 2350 then 2351 return False; 2352 2353 -- The following combinations may lead to aliasing 2354 2355 -- Formal 1 Formal 2 2356 -- IN OUT 2357 -- IN IN OUT 2358 -- OUT IN 2359 -- OUT IN OUT 2360 -- OUT OUT 2361 2362 else 2363 return True; 2364 end if; 2365 end May_Cause_Aliasing; 2366 2367 --------------------- 2368 -- Original_Actual -- 2369 --------------------- 2370 2371 function Original_Actual (N : Node_Id) return Node_Id is 2372 begin 2373 if Nkind (N) = N_Type_Conversion then 2374 return Expression (N); 2375 2376 -- The expander created a temporary to capture the result of a type 2377 -- conversion where the expression is the real actual. 2378 2379 elsif Nkind (N) = N_Identifier 2380 and then Present (Original_Node (N)) 2381 and then Nkind (Original_Node (N)) = N_Type_Conversion 2382 then 2383 return Expression (Original_Node (N)); 2384 end if; 2385 2386 return N; 2387 end Original_Actual; 2388 2389 ------------------- 2390 -- Overlap_Check -- 2391 ------------------- 2392 2393 procedure Overlap_Check 2394 (Actual_1 : Node_Id; 2395 Actual_2 : Node_Id; 2396 Formal_1 : Entity_Id; 2397 Formal_2 : Entity_Id; 2398 Check : in out Node_Id) 2399 is 2400 Cond : Node_Id; 2401 ID_Casing : constant Casing_Type := 2402 Identifier_Casing (Source_Index (Current_Sem_Unit)); 2403 2404 begin 2405 -- Generate: 2406 -- Actual_1'Overlaps_Storage (Actual_2) 2407 2408 Cond := 2409 Make_Attribute_Reference (Loc, 2410 Prefix => New_Copy_Tree (Original_Actual (Actual_1)), 2411 Attribute_Name => Name_Overlaps_Storage, 2412 Expressions => 2413 New_List (New_Copy_Tree (Original_Actual (Actual_2)))); 2414 2415 -- Generate the following check when detailed exception messages are 2416 -- enabled: 2417 2418 -- if Actual_1'Overlaps_Storage (Actual_2) then 2419 -- raise Program_Error with <detailed message>; 2420 -- end if; 2421 2422 if Exception_Extra_Info then 2423 Start_String; 2424 2425 -- Do not generate location information for internal calls 2426 2427 if Comes_From_Source (Call) then 2428 Store_String_Chars (Build_Location_String (Loc)); 2429 Store_String_Char (' '); 2430 end if; 2431 2432 Store_String_Chars ("aliased parameters, actuals for """); 2433 2434 Get_Name_String (Chars (Formal_1)); 2435 Set_Casing (ID_Casing); 2436 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 2437 2438 Store_String_Chars (""" and """); 2439 2440 Get_Name_String (Chars (Formal_2)); 2441 Set_Casing (ID_Casing); 2442 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 2443 2444 Store_String_Chars (""" overlap"); 2445 2446 Insert_Action (Call, 2447 Make_If_Statement (Loc, 2448 Condition => Cond, 2449 Then_Statements => New_List ( 2450 Make_Raise_Statement (Loc, 2451 Name => 2452 New_Occurrence_Of (Standard_Program_Error, Loc), 2453 Expression => Make_String_Literal (Loc, End_String))))); 2454 2455 -- Create a sequence of overlapping checks by and-ing them all 2456 -- together. 2457 2458 else 2459 if No (Check) then 2460 Check := Cond; 2461 else 2462 Check := 2463 Make_And_Then (Loc, 2464 Left_Opnd => Check, 2465 Right_Opnd => Cond); 2466 end if; 2467 end if; 2468 end Overlap_Check; 2469 2470 -- Local variables 2471 2472 Actual_1 : Node_Id; 2473 Actual_2 : Node_Id; 2474 Check : Node_Id; 2475 Formal_1 : Entity_Id; 2476 Formal_2 : Entity_Id; 2477 Orig_Act_1 : Node_Id; 2478 Orig_Act_2 : Node_Id; 2479 2480 -- Start of processing for Apply_Parameter_Aliasing_Checks 2481 2482 begin 2483 Check := Empty; 2484 2485 Actual_1 := First_Actual (Call); 2486 Formal_1 := First_Formal (Subp); 2487 while Present (Actual_1) and then Present (Formal_1) loop 2488 Orig_Act_1 := Original_Actual (Actual_1); 2489 2490 -- Ensure that the actual is an object that is not passed by value. 2491 -- Elementary types are always passed by value, therefore actuals of 2492 -- such types cannot lead to aliasing. An aggregate is an object in 2493 -- Ada 2012, but an actual that is an aggregate cannot overlap with 2494 -- another actual. A type that is By_Reference (such as an array of 2495 -- controlled types) is not subject to the check because any update 2496 -- will be done in place and a subsequent read will always see the 2497 -- correct value, see RM 6.2 (12/3). 2498 2499 if Nkind (Orig_Act_1) = N_Aggregate 2500 or else (Nkind (Orig_Act_1) = N_Qualified_Expression 2501 and then Nkind (Expression (Orig_Act_1)) = N_Aggregate) 2502 then 2503 null; 2504 2505 elsif Is_Object_Reference (Orig_Act_1) 2506 and then not Is_Elementary_Type (Etype (Orig_Act_1)) 2507 and then not Is_By_Reference_Type (Etype (Orig_Act_1)) 2508 then 2509 Actual_2 := Next_Actual (Actual_1); 2510 Formal_2 := Next_Formal (Formal_1); 2511 while Present (Actual_2) and then Present (Formal_2) loop 2512 Orig_Act_2 := Original_Actual (Actual_2); 2513 2514 -- The other actual we are testing against must also denote 2515 -- a non pass-by-value object. Generate the check only when 2516 -- the mode of the two formals may lead to aliasing. 2517 2518 if Is_Object_Reference (Orig_Act_2) 2519 and then not Is_Elementary_Type (Etype (Orig_Act_2)) 2520 and then May_Cause_Aliasing (Formal_1, Formal_2) 2521 then 2522 Remove_Side_Effects (Actual_1); 2523 Remove_Side_Effects (Actual_2); 2524 2525 Overlap_Check 2526 (Actual_1 => Actual_1, 2527 Actual_2 => Actual_2, 2528 Formal_1 => Formal_1, 2529 Formal_2 => Formal_2, 2530 Check => Check); 2531 end if; 2532 2533 Next_Actual (Actual_2); 2534 Next_Formal (Formal_2); 2535 end loop; 2536 end if; 2537 2538 Next_Actual (Actual_1); 2539 Next_Formal (Formal_1); 2540 end loop; 2541 2542 -- Place a simple check right before the call 2543 2544 if Present (Check) and then not Exception_Extra_Info then 2545 Insert_Action (Call, 2546 Make_Raise_Program_Error (Loc, 2547 Condition => Check, 2548 Reason => PE_Aliased_Parameters)); 2549 end if; 2550 end Apply_Parameter_Aliasing_Checks; 2551 2552 ------------------------------------- 2553 -- Apply_Parameter_Validity_Checks -- 2554 ------------------------------------- 2555 2556 procedure Apply_Parameter_Validity_Checks (Subp : Entity_Id) is 2557 Subp_Decl : Node_Id; 2558 2559 procedure Add_Validity_Check 2560 (Formal : Entity_Id; 2561 Prag_Nam : Name_Id; 2562 For_Result : Boolean := False); 2563 -- Add a single 'Valid[_Scalars] check which verifies the initialization 2564 -- of Formal. Prag_Nam denotes the pre or post condition pragma name. 2565 -- Set flag For_Result when to verify the result of a function. 2566 2567 ------------------------ 2568 -- Add_Validity_Check -- 2569 ------------------------ 2570 2571 procedure Add_Validity_Check 2572 (Formal : Entity_Id; 2573 Prag_Nam : Name_Id; 2574 For_Result : Boolean := False) 2575 is 2576 procedure Build_Pre_Post_Condition (Expr : Node_Id); 2577 -- Create a pre/postcondition pragma that tests expression Expr 2578 2579 ------------------------------ 2580 -- Build_Pre_Post_Condition -- 2581 ------------------------------ 2582 2583 procedure Build_Pre_Post_Condition (Expr : Node_Id) is 2584 Loc : constant Source_Ptr := Sloc (Subp); 2585 Decls : List_Id; 2586 Prag : Node_Id; 2587 2588 begin 2589 Prag := 2590 Make_Pragma (Loc, 2591 Chars => Prag_Nam, 2592 Pragma_Argument_Associations => New_List ( 2593 Make_Pragma_Argument_Association (Loc, 2594 Chars => Name_Check, 2595 Expression => Expr))); 2596 2597 -- Add a message unless exception messages are suppressed 2598 2599 if not Exception_Locations_Suppressed then 2600 Append_To (Pragma_Argument_Associations (Prag), 2601 Make_Pragma_Argument_Association (Loc, 2602 Chars => Name_Message, 2603 Expression => 2604 Make_String_Literal (Loc, 2605 Strval => "failed " 2606 & Get_Name_String (Prag_Nam) 2607 & " from " 2608 & Build_Location_String (Loc)))); 2609 end if; 2610 2611 -- Insert the pragma in the tree 2612 2613 if Nkind (Parent (Subp_Decl)) = N_Compilation_Unit then 2614 Add_Global_Declaration (Prag); 2615 Analyze (Prag); 2616 2617 -- PPC pragmas associated with subprogram bodies must be inserted 2618 -- in the declarative part of the body. 2619 2620 elsif Nkind (Subp_Decl) = N_Subprogram_Body then 2621 Decls := Declarations (Subp_Decl); 2622 2623 if No (Decls) then 2624 Decls := New_List; 2625 Set_Declarations (Subp_Decl, Decls); 2626 end if; 2627 2628 Prepend_To (Decls, Prag); 2629 Analyze (Prag); 2630 2631 -- For subprogram declarations insert the PPC pragma right after 2632 -- the declarative node. 2633 2634 else 2635 Insert_After_And_Analyze (Subp_Decl, Prag); 2636 end if; 2637 end Build_Pre_Post_Condition; 2638 2639 -- Local variables 2640 2641 Loc : constant Source_Ptr := Sloc (Subp); 2642 Typ : constant Entity_Id := Etype (Formal); 2643 Check : Node_Id; 2644 Nam : Name_Id; 2645 2646 -- Start of processing for Add_Validity_Check 2647 2648 begin 2649 -- For scalars, generate 'Valid test 2650 2651 if Is_Scalar_Type (Typ) then 2652 Nam := Name_Valid; 2653 2654 -- For any non-scalar with scalar parts, generate 'Valid_Scalars test 2655 2656 elsif Scalar_Part_Present (Typ) then 2657 Nam := Name_Valid_Scalars; 2658 2659 -- No test needed for other cases (no scalars to test) 2660 2661 else 2662 return; 2663 end if; 2664 2665 -- Step 1: Create the expression to verify the validity of the 2666 -- context. 2667 2668 Check := New_Occurrence_Of (Formal, Loc); 2669 2670 -- When processing a function result, use 'Result. Generate 2671 -- Context'Result 2672 2673 if For_Result then 2674 Check := 2675 Make_Attribute_Reference (Loc, 2676 Prefix => Check, 2677 Attribute_Name => Name_Result); 2678 end if; 2679 2680 -- Generate: 2681 -- Context['Result]'Valid[_Scalars] 2682 2683 Check := 2684 Make_Attribute_Reference (Loc, 2685 Prefix => Check, 2686 Attribute_Name => Nam); 2687 2688 -- Step 2: Create a pre or post condition pragma 2689 2690 Build_Pre_Post_Condition (Check); 2691 end Add_Validity_Check; 2692 2693 -- Local variables 2694 2695 Formal : Entity_Id; 2696 Subp_Spec : Node_Id; 2697 2698 -- Start of processing for Apply_Parameter_Validity_Checks 2699 2700 begin 2701 -- Extract the subprogram specification and declaration nodes 2702 2703 Subp_Spec := Parent (Subp); 2704 2705 if Nkind (Subp_Spec) = N_Defining_Program_Unit_Name then 2706 Subp_Spec := Parent (Subp_Spec); 2707 end if; 2708 2709 Subp_Decl := Parent (Subp_Spec); 2710 2711 if not Comes_From_Source (Subp) 2712 2713 -- Do not process formal subprograms because the corresponding actual 2714 -- will receive the proper checks when the instance is analyzed. 2715 2716 or else Is_Formal_Subprogram (Subp) 2717 2718 -- Do not process imported subprograms since pre and postconditions 2719 -- are never verified on routines coming from a different language. 2720 2721 or else Is_Imported (Subp) 2722 or else Is_Intrinsic_Subprogram (Subp) 2723 2724 -- The PPC pragmas generated by this routine do not correspond to 2725 -- source aspects, therefore they cannot be applied to abstract 2726 -- subprograms. 2727 2728 or else Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration 2729 2730 -- Do not consider subprogram renaminds because the renamed entity 2731 -- already has the proper PPC pragmas. 2732 2733 or else Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration 2734 2735 -- Do not process null procedures because there is no benefit of 2736 -- adding the checks to a no action routine. 2737 2738 or else (Nkind (Subp_Spec) = N_Procedure_Specification 2739 and then Null_Present (Subp_Spec)) 2740 then 2741 return; 2742 end if; 2743 2744 -- Inspect all the formals applying aliasing and scalar initialization 2745 -- checks where applicable. 2746 2747 Formal := First_Formal (Subp); 2748 while Present (Formal) loop 2749 2750 -- Generate the following scalar initialization checks for each 2751 -- formal parameter: 2752 2753 -- mode IN - Pre => Formal'Valid[_Scalars] 2754 -- mode IN OUT - Pre, Post => Formal'Valid[_Scalars] 2755 -- mode OUT - Post => Formal'Valid[_Scalars] 2756 2757 if Ekind (Formal) in E_In_Parameter | E_In_Out_Parameter then 2758 Add_Validity_Check (Formal, Name_Precondition, False); 2759 end if; 2760 2761 if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then 2762 Add_Validity_Check (Formal, Name_Postcondition, False); 2763 end if; 2764 2765 Next_Formal (Formal); 2766 end loop; 2767 2768 -- Generate following scalar initialization check for function result: 2769 2770 -- Post => Subp'Result'Valid[_Scalars] 2771 2772 if Ekind (Subp) = E_Function then 2773 Add_Validity_Check (Subp, Name_Postcondition, True); 2774 end if; 2775 end Apply_Parameter_Validity_Checks; 2776 2777 --------------------------- 2778 -- Apply_Predicate_Check -- 2779 --------------------------- 2780 2781 procedure Apply_Predicate_Check 2782 (N : Node_Id; 2783 Typ : Entity_Id; 2784 Fun : Entity_Id := Empty) 2785 is 2786 Par : Node_Id; 2787 S : Entity_Id; 2788 2789 Check_Disabled : constant Boolean := (not Predicate_Enabled (Typ)) 2790 or else not Predicate_Check_In_Scope (N); 2791 begin 2792 S := Current_Scope; 2793 while Present (S) and then not Is_Subprogram (S) loop 2794 S := Scope (S); 2795 end loop; 2796 2797 -- If the check appears within the predicate function itself, it means 2798 -- that the user specified a check whose formal is the predicated 2799 -- subtype itself, rather than some covering type. This is likely to be 2800 -- a common error, and thus deserves a warning. We want to emit this 2801 -- warning even if predicate checking is disabled (in which case the 2802 -- warning is still useful even if it is not strictly accurate). 2803 2804 if Present (S) and then S = Predicate_Function (Typ) then 2805 Error_Msg_NE 2806 ("predicate check includes a call to& that requires a " 2807 & "predicate check??", Parent (N), Fun); 2808 Error_Msg_N 2809 ("\this will result in infinite recursion??", Parent (N)); 2810 2811 if Is_First_Subtype (Typ) then 2812 Error_Msg_NE 2813 ("\use an explicit subtype of& to carry the predicate", 2814 Parent (N), Typ); 2815 end if; 2816 2817 if not Check_Disabled then 2818 Insert_Action (N, 2819 Make_Raise_Storage_Error (Sloc (N), 2820 Reason => SE_Infinite_Recursion)); 2821 return; 2822 end if; 2823 end if; 2824 2825 if Check_Disabled then 2826 return; 2827 end if; 2828 2829 -- Normal case of predicate active 2830 2831 -- If the expression is an IN parameter, the predicate will have 2832 -- been applied at the point of call. An additional check would 2833 -- be redundant, or will lead to out-of-scope references if the 2834 -- call appears within an aspect specification for a precondition. 2835 2836 -- However, if the reference is within the body of the subprogram 2837 -- that declares the formal, the predicate can safely be applied, 2838 -- which may be necessary for a nested call whose formal has a 2839 -- different predicate. 2840 2841 if Is_Entity_Name (N) 2842 and then Ekind (Entity (N)) = E_In_Parameter 2843 then 2844 declare 2845 In_Body : Boolean := False; 2846 P : Node_Id := Parent (N); 2847 2848 begin 2849 while Present (P) loop 2850 if Nkind (P) = N_Subprogram_Body 2851 and then 2852 ((Present (Corresponding_Spec (P)) 2853 and then 2854 Corresponding_Spec (P) = Scope (Entity (N))) 2855 or else 2856 Defining_Unit_Name (Specification (P)) = 2857 Scope (Entity (N))) 2858 then 2859 In_Body := True; 2860 exit; 2861 end if; 2862 2863 P := Parent (P); 2864 end loop; 2865 2866 if not In_Body then 2867 return; 2868 end if; 2869 end; 2870 end if; 2871 2872 -- If the type has a static predicate and the expression is known 2873 -- at compile time, see if the expression satisfies the predicate. 2874 2875 Check_Expression_Against_Static_Predicate (N, Typ); 2876 2877 if not Expander_Active then 2878 return; 2879 end if; 2880 2881 Par := Parent (N); 2882 if Nkind (Par) = N_Qualified_Expression then 2883 Par := Parent (Par); 2884 end if; 2885 2886 -- For an entity of the type, generate a call to the predicate 2887 -- function, unless its type is an actual subtype, which is not 2888 -- visible outside of the enclosing subprogram. 2889 2890 if Is_Entity_Name (N) 2891 and then not Is_Actual_Subtype (Typ) 2892 then 2893 Insert_Action (N, 2894 Make_Predicate_Check 2895 (Typ, New_Occurrence_Of (Entity (N), Sloc (N)))); 2896 return; 2897 2898 elsif Nkind (N) in N_Aggregate | N_Extension_Aggregate then 2899 2900 -- If the expression is an aggregate in an assignment, apply the 2901 -- check to the LHS after the assignment, rather than create a 2902 -- redundant temporary. This is only necessary in rare cases 2903 -- of array types (including strings) initialized with an 2904 -- aggregate with an "others" clause, either coming from source 2905 -- or generated by an Initialize_Scalars pragma. 2906 2907 if Nkind (Par) = N_Assignment_Statement then 2908 Insert_Action_After (Par, 2909 Make_Predicate_Check 2910 (Typ, Duplicate_Subexpr (Name (Par)))); 2911 return; 2912 2913 -- Similarly, if the expression is an aggregate in an object 2914 -- declaration, apply it to the object after the declaration. 2915 -- This is only necessary in rare cases of tagged extensions 2916 -- initialized with an aggregate with an "others => <>" clause. 2917 2918 elsif Nkind (Par) = N_Object_Declaration then 2919 Insert_Action_After (Par, 2920 Make_Predicate_Check (Typ, 2921 New_Occurrence_Of (Defining_Identifier (Par), Sloc (N)))); 2922 return; 2923 end if; 2924 end if; 2925 2926 -- If the expression is not an entity it may have side effects, 2927 -- and the following call will create an object declaration for 2928 -- it. We disable checks during its analysis, to prevent an 2929 -- infinite recursion. 2930 2931 Insert_Action (N, 2932 Make_Predicate_Check 2933 (Typ, Duplicate_Subexpr (N)), Suppress => All_Checks); 2934 end Apply_Predicate_Check; 2935 2936 ----------------------- 2937 -- Apply_Range_Check -- 2938 ----------------------- 2939 2940 procedure Apply_Range_Check 2941 (Expr : Node_Id; 2942 Target_Typ : Entity_Id; 2943 Source_Typ : Entity_Id := Empty; 2944 Insert_Node : Node_Id := Empty) 2945 is 2946 Checks_On : constant Boolean := 2947 not Index_Checks_Suppressed (Target_Typ) 2948 or else 2949 not Range_Checks_Suppressed (Target_Typ); 2950 2951 Loc : constant Source_Ptr := Sloc (Expr); 2952 2953 Cond : Node_Id; 2954 R_Cno : Node_Id; 2955 R_Result : Check_Result; 2956 2957 begin 2958 -- Only apply checks when generating code. In GNATprove mode, we do not 2959 -- apply the checks, but we still call Selected_Range_Checks to possibly 2960 -- issue errors on SPARK code when a run-time error can be detected at 2961 -- compile time. 2962 2963 if not GNATprove_Mode then 2964 if not Expander_Active or not Checks_On then 2965 return; 2966 end if; 2967 end if; 2968 2969 R_Result := 2970 Selected_Range_Checks (Expr, Target_Typ, Source_Typ, Insert_Node); 2971 2972 if GNATprove_Mode then 2973 return; 2974 end if; 2975 2976 for J in 1 .. 2 loop 2977 R_Cno := R_Result (J); 2978 exit when No (R_Cno); 2979 2980 -- The range check requires runtime evaluation. Depending on what its 2981 -- triggering condition is, the check may be converted into a compile 2982 -- time constraint check. 2983 2984 if Nkind (R_Cno) = N_Raise_Constraint_Error 2985 and then Present (Condition (R_Cno)) 2986 then 2987 Cond := Condition (R_Cno); 2988 2989 -- Insert the range check before the related context. Note that 2990 -- this action analyses the triggering condition. 2991 2992 if Present (Insert_Node) then 2993 Insert_Action (Insert_Node, R_Cno); 2994 else 2995 Insert_Action (Expr, R_Cno); 2996 end if; 2997 2998 -- The triggering condition evaluates to True, the range check 2999 -- can be converted into a compile time constraint check. 3000 3001 if Is_Entity_Name (Cond) 3002 and then Entity (Cond) = Standard_True 3003 then 3004 -- Since an N_Range is technically not an expression, we have 3005 -- to set one of the bounds to C_E and then just flag the 3006 -- N_Range. The warning message will point to the lower bound 3007 -- and complain about a range, which seems OK. 3008 3009 if Nkind (Expr) = N_Range then 3010 Apply_Compile_Time_Constraint_Error 3011 (Low_Bound (Expr), 3012 "static range out of bounds of}??", 3013 CE_Range_Check_Failed, 3014 Ent => Target_Typ, 3015 Typ => Target_Typ); 3016 3017 Set_Raises_Constraint_Error (Expr); 3018 3019 else 3020 Apply_Compile_Time_Constraint_Error 3021 (Expr, 3022 "static value out of range of}??", 3023 CE_Range_Check_Failed, 3024 Ent => Target_Typ, 3025 Typ => Target_Typ); 3026 end if; 3027 end if; 3028 3029 -- The range check raises Constraint_Error explicitly 3030 3031 elsif Present (Insert_Node) then 3032 R_Cno := 3033 Make_Raise_Constraint_Error (Sloc (Insert_Node), 3034 Reason => CE_Range_Check_Failed); 3035 3036 Insert_Action (Insert_Node, R_Cno); 3037 3038 else 3039 Install_Static_Check (R_Cno, Loc); 3040 end if; 3041 end loop; 3042 end Apply_Range_Check; 3043 3044 ------------------------------ 3045 -- Apply_Scalar_Range_Check -- 3046 ------------------------------ 3047 3048 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag 3049 -- off if it is already set on. 3050 3051 procedure Apply_Scalar_Range_Check 3052 (Expr : Node_Id; 3053 Target_Typ : Entity_Id; 3054 Source_Typ : Entity_Id := Empty; 3055 Fixed_Int : Boolean := False) 3056 is 3057 Parnt : constant Node_Id := Parent (Expr); 3058 S_Typ : Entity_Id; 3059 Arr : Node_Id := Empty; -- initialize to prevent warning 3060 Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning 3061 3062 Is_Subscr_Ref : Boolean; 3063 -- Set true if Expr is a subscript 3064 3065 Is_Unconstrained_Subscr_Ref : Boolean; 3066 -- Set true if Expr is a subscript of an unconstrained array. In this 3067 -- case we do not attempt to do an analysis of the value against the 3068 -- range of the subscript, since we don't know the actual subtype. 3069 3070 Int_Real : Boolean; 3071 -- Set to True if Expr should be regarded as a real value even though 3072 -- the type of Expr might be discrete. 3073 3074 procedure Bad_Value (Warn : Boolean := False); 3075 -- Procedure called if value is determined to be out of range. Warn is 3076 -- True to force a warning instead of an error, even when SPARK_Mode is 3077 -- On. 3078 3079 --------------- 3080 -- Bad_Value -- 3081 --------------- 3082 3083 procedure Bad_Value (Warn : Boolean := False) is 3084 begin 3085 Apply_Compile_Time_Constraint_Error 3086 (Expr, "value not in range of}??", CE_Range_Check_Failed, 3087 Ent => Target_Typ, 3088 Typ => Target_Typ, 3089 Warn => Warn); 3090 end Bad_Value; 3091 3092 -- Start of processing for Apply_Scalar_Range_Check 3093 3094 begin 3095 -- Return if check obviously not needed 3096 3097 if 3098 -- Not needed inside generic 3099 3100 Inside_A_Generic 3101 3102 -- Not needed if previous error 3103 3104 or else Target_Typ = Any_Type 3105 or else Nkind (Expr) = N_Error 3106 3107 -- Not needed for non-scalar type 3108 3109 or else not Is_Scalar_Type (Target_Typ) 3110 3111 -- Not needed if we know node raises CE already 3112 3113 or else Raises_Constraint_Error (Expr) 3114 then 3115 return; 3116 end if; 3117 3118 -- Now, see if checks are suppressed 3119 3120 Is_Subscr_Ref := 3121 Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component; 3122 3123 if Is_Subscr_Ref then 3124 Arr := Prefix (Parnt); 3125 Arr_Typ := Get_Actual_Subtype_If_Available (Arr); 3126 3127 if Is_Access_Type (Arr_Typ) then 3128 Arr_Typ := Designated_Type (Arr_Typ); 3129 end if; 3130 end if; 3131 3132 if not Do_Range_Check (Expr) then 3133 3134 -- Subscript reference. Check for Index_Checks suppressed 3135 3136 if Is_Subscr_Ref then 3137 3138 -- Check array type and its base type 3139 3140 if Index_Checks_Suppressed (Arr_Typ) 3141 or else Index_Checks_Suppressed (Base_Type (Arr_Typ)) 3142 then 3143 return; 3144 3145 -- Check array itself if it is an entity name 3146 3147 elsif Is_Entity_Name (Arr) 3148 and then Index_Checks_Suppressed (Entity (Arr)) 3149 then 3150 return; 3151 3152 -- Check expression itself if it is an entity name 3153 3154 elsif Is_Entity_Name (Expr) 3155 and then Index_Checks_Suppressed (Entity (Expr)) 3156 then 3157 return; 3158 end if; 3159 3160 -- All other cases, check for Range_Checks suppressed 3161 3162 else 3163 -- Check target type and its base type 3164 3165 if Range_Checks_Suppressed (Target_Typ) 3166 or else Range_Checks_Suppressed (Base_Type (Target_Typ)) 3167 then 3168 return; 3169 3170 -- Check expression itself if it is an entity name 3171 3172 elsif Is_Entity_Name (Expr) 3173 and then Range_Checks_Suppressed (Entity (Expr)) 3174 then 3175 return; 3176 3177 -- If Expr is part of an assignment statement, then check left 3178 -- side of assignment if it is an entity name. 3179 3180 elsif Nkind (Parnt) = N_Assignment_Statement 3181 and then Is_Entity_Name (Name (Parnt)) 3182 and then Range_Checks_Suppressed (Entity (Name (Parnt))) 3183 then 3184 return; 3185 end if; 3186 end if; 3187 end if; 3188 3189 -- Do not set range checks if they are killed 3190 3191 if Nkind (Expr) = N_Unchecked_Type_Conversion 3192 and then Kill_Range_Check (Expr) 3193 then 3194 return; 3195 end if; 3196 3197 -- Do not set range checks for any values from System.Scalar_Values 3198 -- since the whole idea of such values is to avoid checking them. 3199 3200 if Is_Entity_Name (Expr) 3201 and then Is_RTU (Scope (Entity (Expr)), System_Scalar_Values) 3202 then 3203 return; 3204 end if; 3205 3206 -- Now see if we need a check 3207 3208 if No (Source_Typ) then 3209 S_Typ := Etype (Expr); 3210 else 3211 S_Typ := Source_Typ; 3212 end if; 3213 3214 if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then 3215 return; 3216 end if; 3217 3218 Is_Unconstrained_Subscr_Ref := 3219 Is_Subscr_Ref and then not Is_Constrained (Arr_Typ); 3220 3221 -- Special checks for floating-point type 3222 3223 if Is_Floating_Point_Type (S_Typ) then 3224 3225 -- Always do a range check if the source type includes infinities and 3226 -- the target type does not include infinities. We do not do this if 3227 -- range checks are killed. 3228 -- If the expression is a literal and the bounds of the type are 3229 -- static constants it may be possible to optimize the check. 3230 3231 if Has_Infinities (S_Typ) 3232 and then not Has_Infinities (Target_Typ) 3233 then 3234 -- If the expression is a literal and the bounds of the type are 3235 -- static constants it may be possible to optimize the check. 3236 3237 if Nkind (Expr) = N_Real_Literal then 3238 declare 3239 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ); 3240 Thi : constant Node_Id := Type_High_Bound (Target_Typ); 3241 3242 begin 3243 if Compile_Time_Known_Value (Tlo) 3244 and then Compile_Time_Known_Value (Thi) 3245 and then Expr_Value_R (Expr) >= Expr_Value_R (Tlo) 3246 and then Expr_Value_R (Expr) <= Expr_Value_R (Thi) 3247 then 3248 return; 3249 else 3250 Enable_Range_Check (Expr); 3251 end if; 3252 end; 3253 3254 else 3255 Enable_Range_Check (Expr); 3256 end if; 3257 end if; 3258 end if; 3259 3260 -- Return if we know expression is definitely in the range of the target 3261 -- type as determined by Determine_Range_To_Discrete. Right now we only 3262 -- do this for discrete target types, i.e. neither for fixed-point nor 3263 -- for floating-point types. But the additional less precise tests below 3264 -- catch these cases. 3265 3266 -- Note: skip this if we are given a source_typ, since the point of 3267 -- supplying a Source_Typ is to stop us looking at the expression. 3268 -- We could sharpen this test to be out parameters only ??? 3269 3270 if Is_Discrete_Type (Target_Typ) 3271 and then not Is_Unconstrained_Subscr_Ref 3272 and then No (Source_Typ) 3273 then 3274 declare 3275 Thi : constant Node_Id := Type_High_Bound (Target_Typ); 3276 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ); 3277 3278 begin 3279 if Compile_Time_Known_Value (Tlo) 3280 and then Compile_Time_Known_Value (Thi) 3281 then 3282 declare 3283 OK : Boolean := False; -- initialize to prevent warning 3284 Hiv : constant Uint := Expr_Value (Thi); 3285 Lov : constant Uint := Expr_Value (Tlo); 3286 Hi : Uint := No_Uint; 3287 Lo : Uint := No_Uint; 3288 3289 begin 3290 -- If range is null, we for sure have a constraint error (we 3291 -- don't even need to look at the value involved, since all 3292 -- possible values will raise CE). 3293 3294 if Lov > Hiv then 3295 3296 -- When SPARK_Mode is On, force a warning instead of 3297 -- an error in that case, as this likely corresponds 3298 -- to deactivated code. 3299 3300 Bad_Value (Warn => SPARK_Mode = On); 3301 3302 -- In GNATprove mode, we enable the range check so that 3303 -- GNATprove will issue a message if it cannot be proved. 3304 3305 if GNATprove_Mode then 3306 Enable_Range_Check (Expr); 3307 end if; 3308 3309 return; 3310 end if; 3311 3312 -- Otherwise determine range of value 3313 3314 Determine_Range_To_Discrete 3315 (Expr, OK, Lo, Hi, Fixed_Int, Assume_Valid => True); 3316 3317 if OK then 3318 3319 -- If definitely in range, all OK 3320 3321 if Lo >= Lov and then Hi <= Hiv then 3322 return; 3323 3324 -- If definitely not in range, warn 3325 3326 elsif Lov > Hi or else Hiv < Lo then 3327 3328 -- Ignore out of range values for System.Priority in 3329 -- CodePeer mode since the actual target compiler may 3330 -- provide a wider range. 3331 3332 if not CodePeer_Mode 3333 or else not Is_RTE (Target_Typ, RE_Priority) 3334 then 3335 Bad_Value; 3336 end if; 3337 3338 return; 3339 3340 -- Otherwise we don't know 3341 3342 else 3343 null; 3344 end if; 3345 end if; 3346 end; 3347 end if; 3348 end; 3349 end if; 3350 3351 Int_Real := 3352 Is_Floating_Point_Type (S_Typ) 3353 or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int); 3354 3355 -- Check if we can determine at compile time whether Expr is in the 3356 -- range of the target type. Note that if S_Typ is within the bounds 3357 -- of Target_Typ then this must be the case. This check is meaningful 3358 -- only if this is not a conversion between integer and real types, 3359 -- unless for a fixed-point type if Fixed_Int is set. 3360 3361 if not Is_Unconstrained_Subscr_Ref 3362 and then (Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ) 3363 or else (Fixed_Int and then Is_Discrete_Type (Target_Typ))) 3364 and then 3365 (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int) 3366 3367 -- Also check if the expression itself is in the range of the 3368 -- target type if it is a known at compile time value. We skip 3369 -- this test if S_Typ is set since for OUT and IN OUT parameters 3370 -- the Expr itself is not relevant to the checking. 3371 3372 or else 3373 (No (Source_Typ) 3374 and then Is_In_Range (Expr, Target_Typ, 3375 Assume_Valid => True, 3376 Fixed_Int => Fixed_Int, 3377 Int_Real => Int_Real))) 3378 then 3379 return; 3380 3381 elsif Is_Out_Of_Range (Expr, Target_Typ, 3382 Assume_Valid => True, 3383 Fixed_Int => Fixed_Int, 3384 Int_Real => Int_Real) 3385 then 3386 Bad_Value; 3387 return; 3388 3389 -- Floating-point case 3390 -- In the floating-point case, we only do range checks if the type is 3391 -- constrained. We definitely do NOT want range checks for unconstrained 3392 -- types, since we want to have infinities, except when 3393 -- Check_Float_Overflow is set. 3394 3395 elsif Is_Floating_Point_Type (S_Typ) then 3396 if Is_Constrained (S_Typ) or else Check_Float_Overflow then 3397 Enable_Range_Check (Expr); 3398 end if; 3399 3400 -- For all other cases we enable a range check unconditionally 3401 3402 else 3403 Enable_Range_Check (Expr); 3404 return; 3405 end if; 3406 end Apply_Scalar_Range_Check; 3407 3408 ---------------------------------- 3409 -- Apply_Selected_Length_Checks -- 3410 ---------------------------------- 3411 3412 procedure Apply_Selected_Length_Checks 3413 (Expr : Node_Id; 3414 Target_Typ : Entity_Id; 3415 Source_Typ : Entity_Id; 3416 Do_Static : Boolean) 3417 is 3418 Checks_On : constant Boolean := 3419 not Index_Checks_Suppressed (Target_Typ) 3420 or else 3421 not Length_Checks_Suppressed (Target_Typ); 3422 3423 Loc : constant Source_Ptr := Sloc (Expr); 3424 3425 Cond : Node_Id; 3426 R_Cno : Node_Id; 3427 R_Result : Check_Result; 3428 3429 begin 3430 -- Only apply checks when generating code 3431 3432 -- Note: this means that we lose some useful warnings if the expander 3433 -- is not active. 3434 3435 if not Expander_Active then 3436 return; 3437 end if; 3438 3439 R_Result := 3440 Selected_Length_Checks (Expr, Target_Typ, Source_Typ, Empty); 3441 3442 for J in 1 .. 2 loop 3443 R_Cno := R_Result (J); 3444 exit when No (R_Cno); 3445 3446 -- A length check may mention an Itype which is attached to a 3447 -- subsequent node. At the top level in a package this can cause 3448 -- an order-of-elaboration problem, so we make sure that the itype 3449 -- is referenced now. 3450 3451 if Ekind (Current_Scope) = E_Package 3452 and then Is_Compilation_Unit (Current_Scope) 3453 then 3454 Ensure_Defined (Target_Typ, Expr); 3455 3456 if Present (Source_Typ) then 3457 Ensure_Defined (Source_Typ, Expr); 3458 3459 elsif Is_Itype (Etype (Expr)) then 3460 Ensure_Defined (Etype (Expr), Expr); 3461 end if; 3462 end if; 3463 3464 -- If the item is a conditional raise of constraint error, then have 3465 -- a look at what check is being performed and ??? 3466 3467 if Nkind (R_Cno) = N_Raise_Constraint_Error 3468 and then Present (Condition (R_Cno)) 3469 then 3470 Cond := Condition (R_Cno); 3471 3472 -- Case where node does not now have a dynamic check 3473 3474 if not Has_Dynamic_Length_Check (Expr) then 3475 3476 -- If checks are on, just insert the check 3477 3478 if Checks_On then 3479 Insert_Action (Expr, R_Cno); 3480 3481 if not Do_Static then 3482 Set_Has_Dynamic_Length_Check (Expr); 3483 end if; 3484 3485 -- If checks are off, then analyze the length check after 3486 -- temporarily attaching it to the tree in case the relevant 3487 -- condition can be evaluated at compile time. We still want a 3488 -- compile time warning in this case. 3489 3490 else 3491 Set_Parent (R_Cno, Expr); 3492 Analyze (R_Cno); 3493 end if; 3494 end if; 3495 3496 -- Output a warning if the condition is known to be True 3497 3498 if Is_Entity_Name (Cond) 3499 and then Entity (Cond) = Standard_True 3500 then 3501 Apply_Compile_Time_Constraint_Error 3502 (Expr, "wrong length for array of}??", 3503 CE_Length_Check_Failed, 3504 Ent => Target_Typ, 3505 Typ => Target_Typ); 3506 3507 -- If we were only doing a static check, or if checks are not 3508 -- on, then we want to delete the check, since it is not needed. 3509 -- We do this by replacing the if statement by a null statement 3510 3511 elsif Do_Static or else not Checks_On then 3512 Remove_Warning_Messages (R_Cno); 3513 Rewrite (R_Cno, Make_Null_Statement (Loc)); 3514 end if; 3515 3516 else 3517 Install_Static_Check (R_Cno, Loc); 3518 end if; 3519 end loop; 3520 end Apply_Selected_Length_Checks; 3521 3522 ------------------------------- 3523 -- Apply_Static_Length_Check -- 3524 ------------------------------- 3525 3526 procedure Apply_Static_Length_Check 3527 (Expr : Node_Id; 3528 Target_Typ : Entity_Id; 3529 Source_Typ : Entity_Id := Empty) 3530 is 3531 begin 3532 Apply_Selected_Length_Checks 3533 (Expr, Target_Typ, Source_Typ, Do_Static => True); 3534 end Apply_Static_Length_Check; 3535 3536 ------------------------------------- 3537 -- Apply_Subscript_Validity_Checks -- 3538 ------------------------------------- 3539 3540 procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is 3541 Sub : Node_Id; 3542 3543 begin 3544 pragma Assert (Nkind (Expr) = N_Indexed_Component); 3545 3546 -- Loop through subscripts 3547 3548 Sub := First (Expressions (Expr)); 3549 while Present (Sub) loop 3550 3551 -- Check one subscript. Note that we do not worry about enumeration 3552 -- type with holes, since we will convert the value to a Pos value 3553 -- for the subscript, and that convert will do the necessary validity 3554 -- check. 3555 3556 Ensure_Valid (Sub, Holes_OK => True); 3557 3558 -- Move to next subscript 3559 3560 Next (Sub); 3561 end loop; 3562 end Apply_Subscript_Validity_Checks; 3563 3564 ---------------------------------- 3565 -- Apply_Type_Conversion_Checks -- 3566 ---------------------------------- 3567 3568 procedure Apply_Type_Conversion_Checks (N : Node_Id) is 3569 Target_Type : constant Entity_Id := Etype (N); 3570 Target_Base : constant Entity_Id := Base_Type (Target_Type); 3571 Expr : constant Node_Id := Expression (N); 3572 3573 Expr_Type : constant Entity_Id := Underlying_Type (Etype (Expr)); 3574 -- Note: if Etype (Expr) is a private type without discriminants, its 3575 -- full view might have discriminants with defaults, so we need the 3576 -- full view here to retrieve the constraints. 3577 3578 begin 3579 if Inside_A_Generic then 3580 return; 3581 3582 -- Skip these checks if serious errors detected, there are some nasty 3583 -- situations of incomplete trees that blow things up. 3584 3585 elsif Serious_Errors_Detected > 0 then 3586 return; 3587 3588 -- Never generate discriminant checks for Unchecked_Union types 3589 3590 elsif Present (Expr_Type) 3591 and then Is_Unchecked_Union (Expr_Type) 3592 then 3593 return; 3594 3595 -- Scalar type conversions of the form Target_Type (Expr) require a 3596 -- range check if we cannot be sure that Expr is in the base type of 3597 -- Target_Typ and also that Expr is in the range of Target_Typ. These 3598 -- are not quite the same condition from an implementation point of 3599 -- view, but clearly the second includes the first. 3600 3601 elsif Is_Scalar_Type (Target_Type) then 3602 declare 3603 Conv_OK : constant Boolean := Conversion_OK (N); 3604 -- If the Conversion_OK flag on the type conversion is set and no 3605 -- floating-point type is involved in the type conversion then 3606 -- fixed-point values must be read as integral values. 3607 3608 Float_To_Int : constant Boolean := 3609 Is_Floating_Point_Type (Expr_Type) 3610 and then Is_Integer_Type (Target_Type); 3611 3612 begin 3613 if not Overflow_Checks_Suppressed (Target_Base) 3614 and then not Overflow_Checks_Suppressed (Target_Type) 3615 and then not 3616 In_Subrange_Of (Expr_Type, Target_Base, Fixed_Int => Conv_OK) 3617 and then not Float_To_Int 3618 then 3619 -- A small optimization: the attribute 'Pos applied to an 3620 -- enumeration type has a known range, even though its type is 3621 -- Universal_Integer. So in numeric conversions it is usually 3622 -- within range of the target integer type. Use the static 3623 -- bounds of the base types to check. Disable this optimization 3624 -- in case of a generic formal discrete type, because we don't 3625 -- necessarily know the upper bound yet. 3626 3627 if Nkind (Expr) = N_Attribute_Reference 3628 and then Attribute_Name (Expr) = Name_Pos 3629 and then Is_Enumeration_Type (Etype (Prefix (Expr))) 3630 and then not Is_Generic_Type (Etype (Prefix (Expr))) 3631 and then Is_Integer_Type (Target_Type) 3632 then 3633 declare 3634 Enum_T : constant Entity_Id := 3635 Root_Type (Etype (Prefix (Expr))); 3636 Int_T : constant Entity_Id := Base_Type (Target_Type); 3637 Last_I : constant Uint := 3638 Intval (High_Bound (Scalar_Range (Int_T))); 3639 Last_E : Uint; 3640 3641 begin 3642 -- Character types have no explicit literals, so we use 3643 -- the known number of characters in the type. 3644 3645 if Root_Type (Enum_T) = Standard_Character then 3646 Last_E := UI_From_Int (255); 3647 3648 elsif Enum_T = Standard_Wide_Character 3649 or else Enum_T = Standard_Wide_Wide_Character 3650 then 3651 Last_E := UI_From_Int (65535); 3652 3653 else 3654 Last_E := 3655 Enumeration_Pos 3656 (Entity (High_Bound (Scalar_Range (Enum_T)))); 3657 end if; 3658 3659 if Last_E > Last_I then 3660 Activate_Overflow_Check (N); 3661 end if; 3662 end; 3663 else 3664 Activate_Overflow_Check (N); 3665 end if; 3666 end if; 3667 3668 if not Range_Checks_Suppressed (Target_Type) 3669 and then not Range_Checks_Suppressed (Expr_Type) 3670 then 3671 if Float_To_Int 3672 and then not GNATprove_Mode 3673 then 3674 Apply_Float_Conversion_Check (Expr, Target_Type); 3675 else 3676 -- Raw conversions involving fixed-point types are expanded 3677 -- separately and do not need a Range_Check flag yet, except 3678 -- in GNATprove_Mode where this expansion is not performed. 3679 -- This does not apply to conversion where fixed-point types 3680 -- are treated as integers, which are precisely generated by 3681 -- this expansion. 3682 3683 if GNATprove_Mode 3684 or else Conv_OK 3685 or else (not Is_Fixed_Point_Type (Expr_Type) 3686 and then not Is_Fixed_Point_Type (Target_Type)) 3687 then 3688 Apply_Scalar_Range_Check 3689 (Expr, Target_Type, Fixed_Int => Conv_OK); 3690 3691 else 3692 Set_Do_Range_Check (Expr, False); 3693 end if; 3694 3695 -- If the target type has predicates, we need to indicate 3696 -- the need for a check, even if Determine_Range finds that 3697 -- the value is within bounds. This may be the case e.g for 3698 -- a division with a constant denominator. 3699 3700 if Has_Predicates (Target_Type) then 3701 Enable_Range_Check (Expr); 3702 end if; 3703 end if; 3704 end if; 3705 end; 3706 3707 elsif Comes_From_Source (N) 3708 and then not Discriminant_Checks_Suppressed (Target_Type) 3709 and then Is_Record_Type (Target_Type) 3710 and then Is_Derived_Type (Target_Type) 3711 and then not Is_Tagged_Type (Target_Type) 3712 and then not Is_Constrained (Target_Type) 3713 and then Present (Stored_Constraint (Target_Type)) 3714 then 3715 -- An unconstrained derived type may have inherited discriminant. 3716 -- Build an actual discriminant constraint list using the stored 3717 -- constraint, to verify that the expression of the parent type 3718 -- satisfies the constraints imposed by the (unconstrained) derived 3719 -- type. This applies to value conversions, not to view conversions 3720 -- of tagged types. 3721 3722 declare 3723 Loc : constant Source_Ptr := Sloc (N); 3724 Cond : Node_Id; 3725 Constraint : Elmt_Id; 3726 Discr_Value : Node_Id; 3727 Discr : Entity_Id; 3728 3729 New_Constraints : constant Elist_Id := New_Elmt_List; 3730 Old_Constraints : constant Elist_Id := 3731 Discriminant_Constraint (Expr_Type); 3732 3733 begin 3734 Constraint := First_Elmt (Stored_Constraint (Target_Type)); 3735 while Present (Constraint) loop 3736 Discr_Value := Node (Constraint); 3737 3738 if Is_Entity_Name (Discr_Value) 3739 and then Ekind (Entity (Discr_Value)) = E_Discriminant 3740 then 3741 Discr := Corresponding_Discriminant (Entity (Discr_Value)); 3742 3743 if Present (Discr) 3744 and then Scope (Discr) = Base_Type (Expr_Type) 3745 then 3746 -- Parent is constrained by new discriminant. Obtain 3747 -- Value of original discriminant in expression. If the 3748 -- new discriminant has been used to constrain more than 3749 -- one of the stored discriminants, this will provide the 3750 -- required consistency check. 3751 3752 Append_Elmt 3753 (Make_Selected_Component (Loc, 3754 Prefix => 3755 Duplicate_Subexpr_No_Checks 3756 (Expr, Name_Req => True), 3757 Selector_Name => 3758 Make_Identifier (Loc, Chars (Discr))), 3759 New_Constraints); 3760 3761 else 3762 -- Discriminant of more remote ancestor ??? 3763 3764 return; 3765 end if; 3766 3767 -- Derived type definition has an explicit value for this 3768 -- stored discriminant. 3769 3770 else 3771 Append_Elmt 3772 (Duplicate_Subexpr_No_Checks (Discr_Value), 3773 New_Constraints); 3774 end if; 3775 3776 Next_Elmt (Constraint); 3777 end loop; 3778 3779 -- Use the unconstrained expression type to retrieve the 3780 -- discriminants of the parent, and apply momentarily the 3781 -- discriminant constraint synthesized above. 3782 3783 Set_Discriminant_Constraint (Expr_Type, New_Constraints); 3784 Cond := Build_Discriminant_Checks (Expr, Expr_Type); 3785 Set_Discriminant_Constraint (Expr_Type, Old_Constraints); 3786 3787 Insert_Action (N, 3788 Make_Raise_Constraint_Error (Loc, 3789 Condition => Cond, 3790 Reason => CE_Discriminant_Check_Failed)); 3791 end; 3792 3793 -- For arrays, checks are set now, but conversions are applied during 3794 -- expansion, to take into accounts changes of representation. The 3795 -- checks become range checks on the base type or length checks on the 3796 -- subtype, depending on whether the target type is unconstrained or 3797 -- constrained. Note that the range check is put on the expression of a 3798 -- type conversion, while the length check is put on the type conversion 3799 -- itself. 3800 3801 elsif Is_Array_Type (Target_Type) then 3802 if Is_Constrained (Target_Type) then 3803 Set_Do_Length_Check (N); 3804 else 3805 Set_Do_Range_Check (Expr); 3806 end if; 3807 end if; 3808 end Apply_Type_Conversion_Checks; 3809 3810 ---------------------------------------------- 3811 -- Apply_Universal_Integer_Attribute_Checks -- 3812 ---------------------------------------------- 3813 3814 procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is 3815 Loc : constant Source_Ptr := Sloc (N); 3816 Typ : constant Entity_Id := Etype (N); 3817 3818 begin 3819 if Inside_A_Generic then 3820 return; 3821 3822 -- Nothing to do if the result type is universal integer 3823 3824 elsif Typ = Universal_Integer then 3825 return; 3826 3827 -- Nothing to do if checks are suppressed 3828 3829 elsif Range_Checks_Suppressed (Typ) 3830 and then Overflow_Checks_Suppressed (Typ) 3831 then 3832 return; 3833 3834 -- Nothing to do if the attribute does not come from source. The 3835 -- internal attributes we generate of this type do not need checks, 3836 -- and furthermore the attempt to check them causes some circular 3837 -- elaboration orders when dealing with packed types. 3838 3839 elsif not Comes_From_Source (N) then 3840 return; 3841 3842 -- If the prefix is a selected component that depends on a discriminant 3843 -- the check may improperly expose a discriminant instead of using 3844 -- the bounds of the object itself. Set the type of the attribute to 3845 -- the base type of the context, so that a check will be imposed when 3846 -- needed (e.g. if the node appears as an index). 3847 3848 elsif Nkind (Prefix (N)) = N_Selected_Component 3849 and then Ekind (Typ) = E_Signed_Integer_Subtype 3850 and then Depends_On_Discriminant (Scalar_Range (Typ)) 3851 then 3852 Set_Etype (N, Base_Type (Typ)); 3853 3854 -- Otherwise, replace the attribute node with a type conversion node 3855 -- whose expression is the attribute, retyped to universal integer, and 3856 -- whose subtype mark is the target type. The call to analyze this 3857 -- conversion will set range and overflow checks as required for proper 3858 -- detection of an out of range value. 3859 3860 else 3861 Set_Etype (N, Universal_Integer); 3862 Set_Analyzed (N, True); 3863 3864 Rewrite (N, 3865 Make_Type_Conversion (Loc, 3866 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 3867 Expression => Relocate_Node (N))); 3868 3869 Analyze_And_Resolve (N, Typ); 3870 return; 3871 end if; 3872 end Apply_Universal_Integer_Attribute_Checks; 3873 3874 ------------------------------------- 3875 -- Atomic_Synchronization_Disabled -- 3876 ------------------------------------- 3877 3878 -- Note: internally Disable/Enable_Atomic_Synchronization is implemented 3879 -- using a bogus check called Atomic_Synchronization. This is to make it 3880 -- more convenient to get exactly the same semantics as [Un]Suppress. 3881 3882 function Atomic_Synchronization_Disabled (E : Entity_Id) return Boolean is 3883 begin 3884 -- If debug flag d.e is set, always return False, i.e. all atomic sync 3885 -- looks enabled, since it is never disabled. 3886 3887 if Debug_Flag_Dot_E then 3888 return False; 3889 3890 -- If debug flag d.d is set then always return True, i.e. all atomic 3891 -- sync looks disabled, since it always tests True. 3892 3893 elsif Debug_Flag_Dot_D then 3894 return True; 3895 3896 -- If entity present, then check result for that entity 3897 3898 elsif Present (E) and then Checks_May_Be_Suppressed (E) then 3899 return Is_Check_Suppressed (E, Atomic_Synchronization); 3900 3901 -- Otherwise result depends on current scope setting 3902 3903 else 3904 return Scope_Suppress.Suppress (Atomic_Synchronization); 3905 end if; 3906 end Atomic_Synchronization_Disabled; 3907 3908 ------------------------------- 3909 -- Build_Discriminant_Checks -- 3910 ------------------------------- 3911 3912 function Build_Discriminant_Checks 3913 (N : Node_Id; 3914 T_Typ : Entity_Id) return Node_Id 3915 is 3916 Loc : constant Source_Ptr := Sloc (N); 3917 Cond : Node_Id; 3918 Disc : Elmt_Id; 3919 Disc_Ent : Entity_Id; 3920 Dref : Node_Id; 3921 Dval : Node_Id; 3922 3923 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id; 3924 3925 function Replace_Current_Instance 3926 (N : Node_Id) return Traverse_Result; 3927 -- Replace a reference to the current instance of the type with the 3928 -- corresponding _init formal of the initialization procedure. Note: 3929 -- this function relies on us currently being within the initialization 3930 -- procedure. 3931 3932 -------------------------------- 3933 -- Aggregate_Discriminant_Val -- 3934 -------------------------------- 3935 3936 function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id is 3937 Assoc : Node_Id; 3938 3939 begin 3940 -- The aggregate has been normalized with named associations. We use 3941 -- the Chars field to locate the discriminant to take into account 3942 -- discriminants in derived types, which carry the same name as those 3943 -- in the parent. 3944 3945 Assoc := First (Component_Associations (N)); 3946 while Present (Assoc) loop 3947 if Chars (First (Choices (Assoc))) = Chars (Disc) then 3948 return Expression (Assoc); 3949 else 3950 Next (Assoc); 3951 end if; 3952 end loop; 3953 3954 -- Discriminant must have been found in the loop above 3955 3956 raise Program_Error; 3957 end Aggregate_Discriminant_Val; 3958 3959 ------------------------------ 3960 -- Replace_Current_Instance -- 3961 ------------------------------ 3962 3963 function Replace_Current_Instance 3964 (N : Node_Id) return Traverse_Result is 3965 begin 3966 if Is_Entity_Name (N) 3967 and then Etype (N) = Entity (N) 3968 then 3969 Rewrite (N, 3970 New_Occurrence_Of (First_Formal (Current_Subprogram), Loc)); 3971 end if; 3972 3973 return OK; 3974 end Replace_Current_Instance; 3975 3976 procedure Search_And_Replace_Current_Instance is new 3977 Traverse_Proc (Replace_Current_Instance); 3978 3979 -- Start of processing for Build_Discriminant_Checks 3980 3981 begin 3982 -- Loop through discriminants evolving the condition 3983 3984 Cond := Empty; 3985 Disc := First_Elmt (Discriminant_Constraint (T_Typ)); 3986 3987 -- For a fully private type, use the discriminants of the parent type 3988 3989 if Is_Private_Type (T_Typ) 3990 and then No (Full_View (T_Typ)) 3991 then 3992 Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ))); 3993 else 3994 Disc_Ent := First_Discriminant (T_Typ); 3995 end if; 3996 3997 while Present (Disc) loop 3998 Dval := Node (Disc); 3999 4000 if Nkind (Dval) = N_Identifier 4001 and then Ekind (Entity (Dval)) = E_Discriminant 4002 then 4003 Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc); 4004 else 4005 Dval := Duplicate_Subexpr_No_Checks (Dval); 4006 end if; 4007 4008 -- Replace references to the current instance of the type with the 4009 -- corresponding _init formal of the initialization procedure. 4010 4011 if Within_Init_Proc then 4012 Search_And_Replace_Current_Instance (Dval); 4013 end if; 4014 4015 -- If we have an Unchecked_Union node, we can infer the discriminants 4016 -- of the node. 4017 4018 if Is_Unchecked_Union (Base_Type (T_Typ)) then 4019 Dref := New_Copy ( 4020 Get_Discriminant_Value ( 4021 First_Discriminant (T_Typ), 4022 T_Typ, 4023 Stored_Constraint (T_Typ))); 4024 4025 elsif Nkind (N) = N_Aggregate then 4026 Dref := 4027 Duplicate_Subexpr_No_Checks 4028 (Aggregate_Discriminant_Val (Disc_Ent)); 4029 4030 elsif Is_Access_Type (Etype (N)) then 4031 Dref := 4032 Make_Selected_Component (Loc, 4033 Prefix => 4034 Make_Explicit_Dereference (Loc, 4035 Duplicate_Subexpr_No_Checks (N, Name_Req => True)), 4036 Selector_Name => Make_Identifier (Loc, Chars (Disc_Ent))); 4037 4038 Set_Is_In_Discriminant_Check (Dref); 4039 else 4040 Dref := 4041 Make_Selected_Component (Loc, 4042 Prefix => 4043 Duplicate_Subexpr_No_Checks (N, Name_Req => True), 4044 Selector_Name => Make_Identifier (Loc, Chars (Disc_Ent))); 4045 4046 Set_Is_In_Discriminant_Check (Dref); 4047 end if; 4048 4049 Evolve_Or_Else (Cond, 4050 Make_Op_Ne (Loc, 4051 Left_Opnd => Dref, 4052 Right_Opnd => Dval)); 4053 4054 Next_Elmt (Disc); 4055 Next_Discriminant (Disc_Ent); 4056 end loop; 4057 4058 return Cond; 4059 end Build_Discriminant_Checks; 4060 4061 ------------------ 4062 -- Check_Needed -- 4063 ------------------ 4064 4065 function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean is 4066 N : Node_Id; 4067 P : Node_Id; 4068 K : Node_Kind; 4069 L : Node_Id; 4070 R : Node_Id; 4071 4072 function Left_Expression (Op : Node_Id) return Node_Id; 4073 -- Return the relevant expression from the left operand of the given 4074 -- short circuit form: this is LO itself, except if LO is a qualified 4075 -- expression, a type conversion, or an expression with actions, in 4076 -- which case this is Left_Expression (Expression (LO)). 4077 4078 --------------------- 4079 -- Left_Expression -- 4080 --------------------- 4081 4082 function Left_Expression (Op : Node_Id) return Node_Id is 4083 LE : Node_Id := Left_Opnd (Op); 4084 begin 4085 while Nkind (LE) in N_Qualified_Expression 4086 | N_Type_Conversion 4087 | N_Expression_With_Actions 4088 loop 4089 LE := Expression (LE); 4090 end loop; 4091 4092 return LE; 4093 end Left_Expression; 4094 4095 -- Start of processing for Check_Needed 4096 4097 begin 4098 -- Always check if not simple entity 4099 4100 if Nkind (Nod) not in N_Has_Entity 4101 or else not Comes_From_Source (Nod) 4102 then 4103 return True; 4104 end if; 4105 4106 -- Look up tree for short circuit 4107 4108 N := Nod; 4109 loop 4110 P := Parent (N); 4111 K := Nkind (P); 4112 4113 -- Done if out of subexpression (note that we allow generated stuff 4114 -- such as itype declarations in this context, to keep the loop going 4115 -- since we may well have generated such stuff in complex situations. 4116 -- Also done if no parent (probably an error condition, but no point 4117 -- in behaving nasty if we find it). 4118 4119 if No (P) 4120 or else (K not in N_Subexpr and then Comes_From_Source (P)) 4121 then 4122 return True; 4123 4124 -- Or/Or Else case, where test is part of the right operand, or is 4125 -- part of one of the actions associated with the right operand, and 4126 -- the left operand is an equality test. 4127 4128 elsif K = N_Op_Or then 4129 exit when N = Right_Opnd (P) 4130 and then Nkind (Left_Expression (P)) = N_Op_Eq; 4131 4132 elsif K = N_Or_Else then 4133 exit when (N = Right_Opnd (P) 4134 or else 4135 (Is_List_Member (N) 4136 and then List_Containing (N) = Actions (P))) 4137 and then Nkind (Left_Expression (P)) = N_Op_Eq; 4138 4139 -- Similar test for the And/And then case, where the left operand 4140 -- is an inequality test. 4141 4142 elsif K = N_Op_And then 4143 exit when N = Right_Opnd (P) 4144 and then Nkind (Left_Expression (P)) = N_Op_Ne; 4145 4146 elsif K = N_And_Then then 4147 exit when (N = Right_Opnd (P) 4148 or else 4149 (Is_List_Member (N) 4150 and then List_Containing (N) = Actions (P))) 4151 and then Nkind (Left_Expression (P)) = N_Op_Ne; 4152 end if; 4153 4154 N := P; 4155 end loop; 4156 4157 -- If we fall through the loop, then we have a conditional with an 4158 -- appropriate test as its left operand, so look further. 4159 4160 L := Left_Expression (P); 4161 4162 -- L is an "=" or "/=" operator: extract its operands 4163 4164 R := Right_Opnd (L); 4165 L := Left_Opnd (L); 4166 4167 -- Left operand of test must match original variable 4168 4169 if Nkind (L) not in N_Has_Entity or else Entity (L) /= Entity (Nod) then 4170 return True; 4171 end if; 4172 4173 -- Right operand of test must be key value (zero or null) 4174 4175 case Check is 4176 when Access_Check => 4177 if not Known_Null (R) then 4178 return True; 4179 end if; 4180 4181 when Division_Check => 4182 if not Compile_Time_Known_Value (R) 4183 or else Expr_Value (R) /= Uint_0 4184 then 4185 return True; 4186 end if; 4187 4188 when others => 4189 raise Program_Error; 4190 end case; 4191 4192 -- Here we have the optimizable case, warn if not short-circuited 4193 4194 if K = N_Op_And or else K = N_Op_Or then 4195 Error_Msg_Warn := SPARK_Mode /= On; 4196 4197 case Check is 4198 when Access_Check => 4199 if GNATprove_Mode then 4200 Error_Msg_N 4201 ("Constraint_Error might have been raised (access check)", 4202 Parent (Nod)); 4203 else 4204 Error_Msg_N 4205 ("Constraint_Error may be raised (access check)??", 4206 Parent (Nod)); 4207 end if; 4208 4209 when Division_Check => 4210 if GNATprove_Mode then 4211 Error_Msg_N 4212 ("Constraint_Error might have been raised (zero divide)", 4213 Parent (Nod)); 4214 else 4215 Error_Msg_N 4216 ("Constraint_Error may be raised (zero divide)??", 4217 Parent (Nod)); 4218 end if; 4219 4220 when others => 4221 raise Program_Error; 4222 end case; 4223 4224 if K = N_Op_And then 4225 Error_Msg_N -- CODEFIX 4226 ("use `AND THEN` instead of AND??", P); 4227 else 4228 Error_Msg_N -- CODEFIX 4229 ("use `OR ELSE` instead of OR??", P); 4230 end if; 4231 4232 -- If not short-circuited, we need the check 4233 4234 return True; 4235 4236 -- If short-circuited, we can omit the check 4237 4238 else 4239 return False; 4240 end if; 4241 end Check_Needed; 4242 4243 ----------------------------------- 4244 -- Check_Valid_Lvalue_Subscripts -- 4245 ----------------------------------- 4246 4247 procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is 4248 begin 4249 -- Skip this if range checks are suppressed 4250 4251 if Range_Checks_Suppressed (Etype (Expr)) then 4252 return; 4253 4254 -- Only do this check for expressions that come from source. We assume 4255 -- that expander generated assignments explicitly include any necessary 4256 -- checks. Note that this is not just an optimization, it avoids 4257 -- infinite recursions. 4258 4259 elsif not Comes_From_Source (Expr) then 4260 return; 4261 4262 -- For a selected component, check the prefix 4263 4264 elsif Nkind (Expr) = N_Selected_Component then 4265 Check_Valid_Lvalue_Subscripts (Prefix (Expr)); 4266 return; 4267 4268 -- Case of indexed component 4269 4270 elsif Nkind (Expr) = N_Indexed_Component then 4271 Apply_Subscript_Validity_Checks (Expr); 4272 4273 -- Prefix may itself be or contain an indexed component, and these 4274 -- subscripts need checking as well. 4275 4276 Check_Valid_Lvalue_Subscripts (Prefix (Expr)); 4277 end if; 4278 end Check_Valid_Lvalue_Subscripts; 4279 4280 ---------------------------------- 4281 -- Null_Exclusion_Static_Checks -- 4282 ---------------------------------- 4283 4284 procedure Null_Exclusion_Static_Checks 4285 (N : Node_Id; 4286 Comp : Node_Id := Empty; 4287 Array_Comp : Boolean := False) 4288 is 4289 Has_Null : constant Boolean := Has_Null_Exclusion (N); 4290 Kind : constant Node_Kind := Nkind (N); 4291 Error_Nod : Node_Id; 4292 Expr : Node_Id; 4293 Typ : Entity_Id; 4294 4295 begin 4296 pragma Assert 4297 (Kind in N_Component_Declaration 4298 | N_Discriminant_Specification 4299 | N_Function_Specification 4300 | N_Object_Declaration 4301 | N_Parameter_Specification); 4302 4303 if Kind = N_Function_Specification then 4304 Typ := Etype (Defining_Entity (N)); 4305 else 4306 Typ := Etype (Defining_Identifier (N)); 4307 end if; 4308 4309 case Kind is 4310 when N_Component_Declaration => 4311 if Present (Access_Definition (Component_Definition (N))) then 4312 Error_Nod := Component_Definition (N); 4313 else 4314 Error_Nod := Subtype_Indication (Component_Definition (N)); 4315 end if; 4316 4317 when N_Discriminant_Specification => 4318 Error_Nod := Discriminant_Type (N); 4319 4320 when N_Function_Specification => 4321 Error_Nod := Result_Definition (N); 4322 4323 when N_Object_Declaration => 4324 Error_Nod := Object_Definition (N); 4325 4326 when N_Parameter_Specification => 4327 Error_Nod := Parameter_Type (N); 4328 4329 when others => 4330 raise Program_Error; 4331 end case; 4332 4333 if Has_Null then 4334 4335 -- Enforce legality rule 3.10 (13): A null exclusion can only be 4336 -- applied to an access [sub]type. 4337 4338 if not Is_Access_Type (Typ) then 4339 Error_Msg_N 4340 ("`NOT NULL` allowed only for an access type", Error_Nod); 4341 4342 -- Enforce legality rule RM 3.10(14/1): A null exclusion can only 4343 -- be applied to a [sub]type that does not exclude null already. 4344 4345 elsif Can_Never_Be_Null (Typ) and then Comes_From_Source (Typ) then 4346 Error_Msg_NE 4347 ("`NOT NULL` not allowed (& already excludes null)", 4348 Error_Nod, Typ); 4349 end if; 4350 end if; 4351 4352 -- Check that null-excluding objects are always initialized, except for 4353 -- deferred constants, for which the expression will appear in the full 4354 -- declaration. 4355 4356 if Kind = N_Object_Declaration 4357 and then No (Expression (N)) 4358 and then not Constant_Present (N) 4359 and then not No_Initialization (N) 4360 then 4361 if Present (Comp) then 4362 4363 -- Specialize the warning message to indicate that we are dealing 4364 -- with an uninitialized composite object that has a defaulted 4365 -- null-excluding component. 4366 4367 Error_Msg_Name_1 := Chars (Defining_Identifier (Comp)); 4368 Error_Msg_Name_2 := Chars (Defining_Identifier (N)); 4369 4370 Discard_Node 4371 (Compile_Time_Constraint_Error 4372 (N => N, 4373 Msg => 4374 "(Ada 2005) null-excluding component % of object % must " 4375 & "be initialized??", 4376 Ent => Defining_Identifier (Comp))); 4377 4378 -- This is a case of an array with null-excluding components, so 4379 -- indicate that in the warning. 4380 4381 elsif Array_Comp then 4382 Discard_Node 4383 (Compile_Time_Constraint_Error 4384 (N => N, 4385 Msg => 4386 "(Ada 2005) null-excluding array components must " 4387 & "be initialized??", 4388 Ent => Defining_Identifier (N))); 4389 4390 -- Normal case of object of a null-excluding access type 4391 4392 else 4393 -- Add an expression that assigns null. This node is needed by 4394 -- Apply_Compile_Time_Constraint_Error, which will replace this 4395 -- with a Constraint_Error node. 4396 4397 Set_Expression (N, Make_Null (Sloc (N))); 4398 Set_Etype (Expression (N), Etype (Defining_Identifier (N))); 4399 4400 Apply_Compile_Time_Constraint_Error 4401 (N => Expression (N), 4402 Msg => 4403 "(Ada 2005) null-excluding objects must be initialized??", 4404 Reason => CE_Null_Not_Allowed); 4405 end if; 4406 end if; 4407 4408 -- Check that a null-excluding component, formal or object is not being 4409 -- assigned a null value. Otherwise generate a warning message and 4410 -- replace Expression (N) by an N_Constraint_Error node. 4411 4412 if Kind /= N_Function_Specification then 4413 Expr := Expression (N); 4414 4415 if Present (Expr) and then Known_Null (Expr) then 4416 case Kind is 4417 when N_Component_Declaration 4418 | N_Discriminant_Specification 4419 => 4420 Apply_Compile_Time_Constraint_Error 4421 (N => Expr, 4422 Msg => 4423 "(Ada 2005) NULL not allowed in null-excluding " 4424 & "components??", 4425 Reason => CE_Null_Not_Allowed); 4426 4427 when N_Object_Declaration => 4428 Apply_Compile_Time_Constraint_Error 4429 (N => Expr, 4430 Msg => 4431 "(Ada 2005) NULL not allowed in null-excluding " 4432 & "objects??", 4433 Reason => CE_Null_Not_Allowed); 4434 4435 when N_Parameter_Specification => 4436 Apply_Compile_Time_Constraint_Error 4437 (N => Expr, 4438 Msg => 4439 "(Ada 2005) NULL not allowed in null-excluding " 4440 & "formals??", 4441 Reason => CE_Null_Not_Allowed); 4442 4443 when others => 4444 null; 4445 end case; 4446 end if; 4447 end if; 4448 end Null_Exclusion_Static_Checks; 4449 4450 ------------------------------------- 4451 -- Compute_Range_For_Arithmetic_Op -- 4452 ------------------------------------- 4453 4454 procedure Compute_Range_For_Arithmetic_Op 4455 (Op : Node_Kind; 4456 Lo_Left : Uint; 4457 Hi_Left : Uint; 4458 Lo_Right : Uint; 4459 Hi_Right : Uint; 4460 OK : out Boolean; 4461 Lo : out Uint; 4462 Hi : out Uint) 4463 is 4464 -- Use local variables for possible adjustments 4465 4466 Llo : Uint renames Lo_Left; 4467 Lhi : Uint renames Hi_Left; 4468 Rlo : Uint := Lo_Right; 4469 Rhi : Uint := Hi_Right; 4470 4471 begin 4472 -- We will compute a range for the result in almost all cases 4473 4474 OK := True; 4475 4476 case Op is 4477 4478 -- Absolute value 4479 4480 when N_Op_Abs => 4481 Lo := Uint_0; 4482 Hi := UI_Max (abs Rlo, abs Rhi); 4483 4484 -- Addition 4485 4486 when N_Op_Add => 4487 Lo := Llo + Rlo; 4488 Hi := Lhi + Rhi; 4489 4490 -- Division 4491 4492 when N_Op_Divide => 4493 4494 -- If the right operand can only be zero, set 0..0 4495 4496 if Rlo = 0 and then Rhi = 0 then 4497 Lo := Uint_0; 4498 Hi := Uint_0; 4499 4500 -- Possible bounds of division must come from dividing end 4501 -- values of the input ranges (four possibilities), provided 4502 -- zero is not included in the possible values of the right 4503 -- operand. 4504 4505 -- Otherwise, we just consider two intervals of values for 4506 -- the right operand: the interval of negative values (up to 4507 -- -1) and the interval of positive values (starting at 1). 4508 -- Since division by 1 is the identity, and division by -1 4509 -- is negation, we get all possible bounds of division in that 4510 -- case by considering: 4511 -- - all values from the division of end values of input 4512 -- ranges; 4513 -- - the end values of the left operand; 4514 -- - the negation of the end values of the left operand. 4515 4516 else 4517 declare 4518 Mrk : constant Uintp.Save_Mark := Mark; 4519 -- Mark so we can release the RR and Ev values 4520 4521 Ev1 : Uint; 4522 Ev2 : Uint; 4523 Ev3 : Uint; 4524 Ev4 : Uint; 4525 4526 begin 4527 -- Discard extreme values of zero for the divisor, since 4528 -- they will simply result in an exception in any case. 4529 4530 if Rlo = 0 then 4531 Rlo := Uint_1; 4532 elsif Rhi = 0 then 4533 Rhi := -Uint_1; 4534 end if; 4535 4536 -- Compute possible bounds coming from dividing end 4537 -- values of the input ranges. 4538 4539 Ev1 := Llo / Rlo; 4540 Ev2 := Llo / Rhi; 4541 Ev3 := Lhi / Rlo; 4542 Ev4 := Lhi / Rhi; 4543 4544 Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4)); 4545 Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4)); 4546 4547 -- If the right operand can be both negative or positive, 4548 -- include the end values of the left operand in the 4549 -- extreme values, as well as their negation. 4550 4551 if Rlo < 0 and then Rhi > 0 then 4552 Ev1 := Llo; 4553 Ev2 := -Llo; 4554 Ev3 := Lhi; 4555 Ev4 := -Lhi; 4556 4557 Lo := UI_Min (Lo, 4558 UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4))); 4559 Hi := UI_Max (Hi, 4560 UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4))); 4561 end if; 4562 4563 -- Release the RR and Ev values 4564 4565 Release_And_Save (Mrk, Lo, Hi); 4566 end; 4567 end if; 4568 4569 -- Exponentiation 4570 4571 when N_Op_Expon => 4572 4573 -- Discard negative values for the exponent, since they will 4574 -- simply result in an exception in any case. 4575 4576 if Rhi < 0 then 4577 Rhi := Uint_0; 4578 elsif Rlo < 0 then 4579 Rlo := Uint_0; 4580 end if; 4581 4582 -- Estimate number of bits in result before we go computing 4583 -- giant useless bounds. Basically the number of bits in the 4584 -- result is the number of bits in the base multiplied by the 4585 -- value of the exponent. If this is big enough that the result 4586 -- definitely won't fit in Long_Long_Integer, return immediately 4587 -- and avoid computing giant bounds. 4588 4589 -- The comparison here is approximate, but conservative, it 4590 -- only clicks on cases that are sure to exceed the bounds. 4591 4592 if Num_Bits (UI_Max (abs Llo, abs Lhi)) * Rhi + 1 > 100 then 4593 Lo := No_Uint; 4594 Hi := No_Uint; 4595 OK := False; 4596 return; 4597 4598 -- If right operand is zero then result is 1 4599 4600 elsif Rhi = 0 then 4601 Lo := Uint_1; 4602 Hi := Uint_1; 4603 4604 else 4605 -- High bound comes either from exponentiation of largest 4606 -- positive value to largest exponent value, or from 4607 -- the exponentiation of most negative value to an 4608 -- even exponent. 4609 4610 declare 4611 Hi1, Hi2 : Uint; 4612 4613 begin 4614 if Lhi > 0 then 4615 Hi1 := Lhi ** Rhi; 4616 else 4617 Hi1 := Uint_0; 4618 end if; 4619 4620 if Llo < 0 then 4621 if Rhi mod 2 = 0 then 4622 Hi2 := Llo ** Rhi; 4623 else 4624 Hi2 := Llo ** (Rhi - 1); 4625 end if; 4626 else 4627 Hi2 := Uint_0; 4628 end if; 4629 4630 Hi := UI_Max (Hi1, Hi2); 4631 end; 4632 4633 -- Result can only be negative if base can be negative 4634 4635 if Llo < 0 then 4636 if Rhi mod 2 = 0 then 4637 Lo := Llo ** (Rhi - 1); 4638 else 4639 Lo := Llo ** Rhi; 4640 end if; 4641 4642 -- Otherwise low bound is minimum ** minimum 4643 4644 else 4645 Lo := Llo ** Rlo; 4646 end if; 4647 end if; 4648 4649 -- Negation 4650 4651 when N_Op_Minus => 4652 Lo := -Rhi; 4653 Hi := -Rlo; 4654 4655 -- Mod 4656 4657 when N_Op_Mod => 4658 declare 4659 Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1; 4660 -- This is the maximum absolute value of the result 4661 4662 begin 4663 Lo := Uint_0; 4664 Hi := Uint_0; 4665 4666 -- The result depends only on the sign and magnitude of 4667 -- the right operand, it does not depend on the sign or 4668 -- magnitude of the left operand. 4669 4670 if Rlo < 0 then 4671 Lo := -Maxabs; 4672 end if; 4673 4674 if Rhi > 0 then 4675 Hi := Maxabs; 4676 end if; 4677 end; 4678 4679 -- Multiplication 4680 4681 when N_Op_Multiply => 4682 4683 -- Possible bounds of multiplication must come from multiplying 4684 -- end values of the input ranges (four possibilities). 4685 4686 declare 4687 Mrk : constant Uintp.Save_Mark := Mark; 4688 -- Mark so we can release the Ev values 4689 4690 Ev1 : constant Uint := Llo * Rlo; 4691 Ev2 : constant Uint := Llo * Rhi; 4692 Ev3 : constant Uint := Lhi * Rlo; 4693 Ev4 : constant Uint := Lhi * Rhi; 4694 4695 begin 4696 Lo := UI_Min (UI_Min (Ev1, Ev2), UI_Min (Ev3, Ev4)); 4697 Hi := UI_Max (UI_Max (Ev1, Ev2), UI_Max (Ev3, Ev4)); 4698 4699 -- Release the Ev values 4700 4701 Release_And_Save (Mrk, Lo, Hi); 4702 end; 4703 4704 -- Plus operator (affirmation) 4705 4706 when N_Op_Plus => 4707 Lo := Rlo; 4708 Hi := Rhi; 4709 4710 -- Remainder 4711 4712 when N_Op_Rem => 4713 declare 4714 Maxabs : constant Uint := UI_Max (abs Rlo, abs Rhi) - 1; 4715 -- This is the maximum absolute value of the result. Note 4716 -- that the result range does not depend on the sign of the 4717 -- right operand. 4718 4719 begin 4720 Lo := Uint_0; 4721 Hi := Uint_0; 4722 4723 -- Case of left operand negative, which results in a range 4724 -- of -Maxabs .. 0 for those negative values. If there are 4725 -- no negative values then Lo value of result is always 0. 4726 4727 if Llo < 0 then 4728 Lo := -Maxabs; 4729 end if; 4730 4731 -- Case of left operand positive 4732 4733 if Lhi > 0 then 4734 Hi := Maxabs; 4735 end if; 4736 end; 4737 4738 -- Subtract 4739 4740 when N_Op_Subtract => 4741 Lo := Llo - Rhi; 4742 Hi := Lhi - Rlo; 4743 4744 -- Nothing else should be possible 4745 4746 when others => 4747 raise Program_Error; 4748 end case; 4749 end Compute_Range_For_Arithmetic_Op; 4750 4751 ---------------------------------- 4752 -- Conditional_Statements_Begin -- 4753 ---------------------------------- 4754 4755 procedure Conditional_Statements_Begin is 4756 begin 4757 Saved_Checks_TOS := Saved_Checks_TOS + 1; 4758 4759 -- If stack overflows, kill all checks, that way we know to simply reset 4760 -- the number of saved checks to zero on return. This should never occur 4761 -- in practice. 4762 4763 if Saved_Checks_TOS > Saved_Checks_Stack'Last then 4764 Kill_All_Checks; 4765 4766 -- In the normal case, we just make a new stack entry saving the current 4767 -- number of saved checks for a later restore. 4768 4769 else 4770 Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks; 4771 4772 if Debug_Flag_CC then 4773 w ("Conditional_Statements_Begin: Num_Saved_Checks = ", 4774 Num_Saved_Checks); 4775 end if; 4776 end if; 4777 end Conditional_Statements_Begin; 4778 4779 -------------------------------- 4780 -- Conditional_Statements_End -- 4781 -------------------------------- 4782 4783 procedure Conditional_Statements_End is 4784 begin 4785 pragma Assert (Saved_Checks_TOS > 0); 4786 4787 -- If the saved checks stack overflowed, then we killed all checks, so 4788 -- setting the number of saved checks back to zero is correct. This 4789 -- should never occur in practice. 4790 4791 if Saved_Checks_TOS > Saved_Checks_Stack'Last then 4792 Num_Saved_Checks := 0; 4793 4794 -- In the normal case, restore the number of saved checks from the top 4795 -- stack entry. 4796 4797 else 4798 Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS); 4799 4800 if Debug_Flag_CC then 4801 w ("Conditional_Statements_End: Num_Saved_Checks = ", 4802 Num_Saved_Checks); 4803 end if; 4804 end if; 4805 4806 Saved_Checks_TOS := Saved_Checks_TOS - 1; 4807 end Conditional_Statements_End; 4808 4809 ------------------------- 4810 -- Convert_From_Bignum -- 4811 ------------------------- 4812 4813 function Convert_From_Bignum (N : Node_Id) return Node_Id is 4814 Loc : constant Source_Ptr := Sloc (N); 4815 4816 begin 4817 pragma Assert (Is_RTE (Etype (N), RE_Bignum)); 4818 4819 -- Construct call From Bignum 4820 4821 return 4822 Make_Function_Call (Loc, 4823 Name => 4824 New_Occurrence_Of (RTE (RE_From_Bignum), Loc), 4825 Parameter_Associations => New_List (Relocate_Node (N))); 4826 end Convert_From_Bignum; 4827 4828 ----------------------- 4829 -- Convert_To_Bignum -- 4830 ----------------------- 4831 4832 function Convert_To_Bignum (N : Node_Id) return Node_Id is 4833 Loc : constant Source_Ptr := Sloc (N); 4834 4835 begin 4836 -- Nothing to do if Bignum already except call Relocate_Node 4837 4838 if Is_RTE (Etype (N), RE_Bignum) then 4839 return Relocate_Node (N); 4840 4841 -- Otherwise construct call to To_Bignum, converting the operand to the 4842 -- required Long_Long_Integer form. 4843 4844 else 4845 pragma Assert (Is_Signed_Integer_Type (Etype (N))); 4846 return 4847 Make_Function_Call (Loc, 4848 Name => 4849 New_Occurrence_Of (RTE (RE_To_Bignum), Loc), 4850 Parameter_Associations => New_List ( 4851 Convert_To (Standard_Long_Long_Integer, Relocate_Node (N)))); 4852 end if; 4853 end Convert_To_Bignum; 4854 4855 --------------------- 4856 -- Determine_Range -- 4857 --------------------- 4858 4859 Cache_Size : constant := 2 ** 10; 4860 type Cache_Index is range 0 .. Cache_Size - 1; 4861 -- Determine size of below cache (power of 2 is more efficient) 4862 4863 Determine_Range_Cache_N : array (Cache_Index) of Node_Id; 4864 Determine_Range_Cache_O : array (Cache_Index) of Node_Id; 4865 Determine_Range_Cache_V : array (Cache_Index) of Boolean; 4866 Determine_Range_Cache_Lo : array (Cache_Index) of Uint; 4867 Determine_Range_Cache_Hi : array (Cache_Index) of Uint; 4868 Determine_Range_Cache_Lo_R : array (Cache_Index) of Ureal; 4869 Determine_Range_Cache_Hi_R : array (Cache_Index) of Ureal; 4870 -- The above arrays are used to implement a small direct cache for 4871 -- Determine_Range and Determine_Range_R calls. Because of the way these 4872 -- subprograms recursively traces subexpressions, and because overflow 4873 -- checking calls the routine on the way up the tree, a quadratic behavior 4874 -- can otherwise be encountered in large expressions. The cache entry for 4875 -- node N is stored in the (N mod Cache_Size) entry, and can be validated 4876 -- by checking the actual node value stored there. The Range_Cache_O array 4877 -- records the setting of Original_Node (N) so that the cache entry does 4878 -- not become stale when the node N is rewritten. The Range_Cache_V array 4879 -- records the setting of Assume_Valid for the cache entry. 4880 4881 procedure Determine_Range 4882 (N : Node_Id; 4883 OK : out Boolean; 4884 Lo : out Uint; 4885 Hi : out Uint; 4886 Assume_Valid : Boolean := False) 4887 is 4888 Kind : constant Node_Kind := Nkind (N); 4889 -- Kind of node 4890 4891 function Half_Address_Space return Uint; 4892 -- The size of half the total addressable memory space in storage units 4893 -- (minus one, so that the size fits in a signed integer whose size is 4894 -- System_Address_Size, which helps in various cases). 4895 4896 ------------------------ 4897 -- Half_Address_Space -- 4898 ------------------------ 4899 4900 function Half_Address_Space return Uint is 4901 begin 4902 return Uint_2 ** (System_Address_Size - 1) - 1; 4903 end Half_Address_Space; 4904 4905 -- Local variables 4906 4907 Typ : Entity_Id := Etype (N); 4908 -- Type to use, may get reset to base type for possibly invalid entity 4909 4910 Lo_Left : Uint := No_Uint; 4911 Hi_Left : Uint := No_Uint; 4912 -- Lo and Hi bounds of left operand 4913 4914 Lo_Right : Uint := No_Uint; 4915 Hi_Right : Uint := No_Uint; 4916 -- Lo and Hi bounds of right (or only) operand 4917 4918 Bound : Node_Id; 4919 -- Temp variable used to hold a bound node 4920 4921 Hbound : Uint; 4922 -- High bound of base type of expression 4923 4924 Lor : Uint; 4925 Hir : Uint; 4926 -- Refined values for low and high bounds, after tightening 4927 4928 OK1 : Boolean; 4929 -- Used in lower level calls to indicate if call succeeded 4930 4931 Cindex : Cache_Index; 4932 -- Used to search cache 4933 4934 Btyp : Entity_Id; 4935 -- Base type 4936 4937 -- Start of processing for Determine_Range 4938 4939 begin 4940 -- Prevent junk warnings by initializing range variables 4941 4942 Lo := No_Uint; 4943 Hi := No_Uint; 4944 Lor := No_Uint; 4945 Hir := No_Uint; 4946 4947 -- For temporary constants internally generated to remove side effects 4948 -- we must use the corresponding expression to determine the range of 4949 -- the expression. But note that the expander can also generate 4950 -- constants in other cases, including deferred constants. 4951 4952 if Is_Entity_Name (N) 4953 and then Nkind (Parent (Entity (N))) = N_Object_Declaration 4954 and then Ekind (Entity (N)) = E_Constant 4955 and then Is_Internal_Name (Chars (Entity (N))) 4956 then 4957 if Present (Expression (Parent (Entity (N)))) then 4958 Determine_Range 4959 (Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid); 4960 4961 elsif Present (Full_View (Entity (N))) then 4962 Determine_Range 4963 (Expression (Parent (Full_View (Entity (N)))), 4964 OK, Lo, Hi, Assume_Valid); 4965 4966 else 4967 OK := False; 4968 end if; 4969 return; 4970 end if; 4971 4972 -- If type is not defined, we can't determine its range 4973 4974 if No (Typ) 4975 4976 -- We don't deal with anything except discrete types 4977 4978 or else not Is_Discrete_Type (Typ) 4979 4980 -- Don't deal with enumerated types with non-standard representation 4981 4982 or else (Is_Enumeration_Type (Typ) 4983 and then Present (Enum_Pos_To_Rep (Base_Type (Typ)))) 4984 4985 -- Ignore type for which an error has been posted, since range in 4986 -- this case may well be a bogosity deriving from the error. Also 4987 -- ignore if error posted on the reference node. 4988 4989 or else Error_Posted (N) or else Error_Posted (Typ) 4990 then 4991 OK := False; 4992 return; 4993 end if; 4994 4995 -- For all other cases, we can determine the range 4996 4997 OK := True; 4998 4999 -- If value is compile time known, then the possible range is the one 5000 -- value that we know this expression definitely has. 5001 5002 if Compile_Time_Known_Value (N) then 5003 Lo := Expr_Value (N); 5004 Hi := Lo; 5005 return; 5006 end if; 5007 5008 -- Return if already in the cache 5009 5010 Cindex := Cache_Index (N mod Cache_Size); 5011 5012 if Determine_Range_Cache_N (Cindex) = N 5013 and then 5014 Determine_Range_Cache_O (Cindex) = Original_Node (N) 5015 and then 5016 Determine_Range_Cache_V (Cindex) = Assume_Valid 5017 then 5018 Lo := Determine_Range_Cache_Lo (Cindex); 5019 Hi := Determine_Range_Cache_Hi (Cindex); 5020 return; 5021 end if; 5022 5023 -- Otherwise, start by finding the bounds of the type of the expression, 5024 -- the value cannot be outside this range (if it is, then we have an 5025 -- overflow situation, which is a separate check, we are talking here 5026 -- only about the expression value). 5027 5028 -- First a check, never try to find the bounds of a generic type, since 5029 -- these bounds are always junk values, and it is only valid to look at 5030 -- the bounds in an instance. 5031 5032 if Is_Generic_Type (Typ) then 5033 OK := False; 5034 return; 5035 end if; 5036 5037 -- First step, change to use base type unless we know the value is valid 5038 5039 if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N))) 5040 or else Assume_No_Invalid_Values 5041 or else Assume_Valid 5042 then 5043 -- If this is a known valid constant with a nonstatic value, it may 5044 -- have inherited a narrower subtype from its initial value; use this 5045 -- saved subtype (see sem_ch3.adb). 5046 5047 if Is_Entity_Name (N) 5048 and then Ekind (Entity (N)) = E_Constant 5049 and then Present (Actual_Subtype (Entity (N))) 5050 then 5051 Typ := Actual_Subtype (Entity (N)); 5052 end if; 5053 5054 else 5055 Typ := Underlying_Type (Base_Type (Typ)); 5056 end if; 5057 5058 -- Retrieve the base type. Handle the case where the base type is a 5059 -- private enumeration type. 5060 5061 Btyp := Base_Type (Typ); 5062 5063 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then 5064 Btyp := Full_View (Btyp); 5065 end if; 5066 5067 -- We use the actual bound unless it is dynamic, in which case use the 5068 -- corresponding base type bound if possible. If we can't get a bound 5069 -- then we figure we can't determine the range (a peculiar case, that 5070 -- perhaps cannot happen, but there is no point in bombing in this 5071 -- optimization circuit). 5072 5073 -- First the low bound 5074 5075 Bound := Type_Low_Bound (Typ); 5076 5077 if Compile_Time_Known_Value (Bound) then 5078 Lo := Expr_Value (Bound); 5079 5080 elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then 5081 Lo := Expr_Value (Type_Low_Bound (Btyp)); 5082 5083 else 5084 OK := False; 5085 return; 5086 end if; 5087 5088 -- Now the high bound 5089 5090 Bound := Type_High_Bound (Typ); 5091 5092 -- We need the high bound of the base type later on, and this should 5093 -- always be compile time known. Again, it is not clear that this 5094 -- can ever be false, but no point in bombing. 5095 5096 if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then 5097 Hbound := Expr_Value (Type_High_Bound (Btyp)); 5098 Hi := Hbound; 5099 5100 else 5101 OK := False; 5102 return; 5103 end if; 5104 5105 -- If we have a static subtype, then that may have a tighter bound so 5106 -- use the upper bound of the subtype instead in this case. 5107 5108 if Compile_Time_Known_Value (Bound) then 5109 Hi := Expr_Value (Bound); 5110 end if; 5111 5112 -- We may be able to refine this value in certain situations. If any 5113 -- refinement is possible, then Lor and Hir are set to possibly tighter 5114 -- bounds, and OK1 is set to True. 5115 5116 case Kind is 5117 5118 -- Unary operation case 5119 5120 when N_Op_Abs 5121 | N_Op_Minus 5122 | N_Op_Plus 5123 => 5124 Determine_Range 5125 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid); 5126 5127 if OK1 then 5128 Compute_Range_For_Arithmetic_Op 5129 (Kind, Lo_Left, Hi_Left, Lo_Right, Hi_Right, OK1, Lor, Hir); 5130 end if; 5131 5132 -- Binary operation case 5133 5134 when N_Op_Add 5135 | N_Op_Divide 5136 | N_Op_Expon 5137 | N_Op_Mod 5138 | N_Op_Multiply 5139 | N_Op_Rem 5140 | N_Op_Subtract 5141 => 5142 Determine_Range 5143 (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid); 5144 5145 if OK1 then 5146 Determine_Range 5147 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid); 5148 end if; 5149 5150 if OK1 then 5151 Compute_Range_For_Arithmetic_Op 5152 (Kind, Lo_Left, Hi_Left, Lo_Right, Hi_Right, OK1, Lor, Hir); 5153 end if; 5154 5155 -- Attribute reference cases 5156 5157 when N_Attribute_Reference => 5158 case Get_Attribute_Id (Attribute_Name (N)) is 5159 5160 -- For Min/Max attributes, we can refine the range using the 5161 -- possible range of values of the attribute expressions. 5162 5163 when Attribute_Min 5164 | Attribute_Max 5165 => 5166 Determine_Range 5167 (First (Expressions (N)), 5168 OK1, Lo_Left, Hi_Left, Assume_Valid); 5169 5170 if OK1 then 5171 Determine_Range 5172 (Next (First (Expressions (N))), 5173 OK1, Lo_Right, Hi_Right, Assume_Valid); 5174 end if; 5175 5176 if OK1 then 5177 Lor := UI_Min (Lo_Left, Lo_Right); 5178 Hir := UI_Max (Hi_Left, Hi_Right); 5179 end if; 5180 5181 -- For Pos/Val attributes, we can refine the range using the 5182 -- possible range of values of the attribute expression. 5183 5184 when Attribute_Pos 5185 | Attribute_Val 5186 => 5187 Determine_Range 5188 (First (Expressions (N)), OK1, Lor, Hir, Assume_Valid); 5189 5190 -- For Length and Range_Length attributes, use the bounds of 5191 -- the (corresponding index) type to refine the range. 5192 5193 when Attribute_Length 5194 | Attribute_Range_Length 5195 => 5196 declare 5197 Ptyp : Entity_Id; 5198 Ityp : Entity_Id; 5199 5200 LL, LU : Uint; 5201 UL, UU : Uint; 5202 5203 begin 5204 Ptyp := Etype (Prefix (N)); 5205 if Is_Access_Type (Ptyp) then 5206 Ptyp := Designated_Type (Ptyp); 5207 end if; 5208 5209 -- For string literal, we know exact value 5210 5211 if Ekind (Ptyp) = E_String_Literal_Subtype then 5212 OK := True; 5213 Lo := String_Literal_Length (Ptyp); 5214 Hi := String_Literal_Length (Ptyp); 5215 return; 5216 end if; 5217 5218 if Is_Array_Type (Ptyp) then 5219 Ityp := Get_Index_Subtype (N); 5220 else 5221 Ityp := Ptyp; 5222 end if; 5223 5224 -- If the (index) type is a formal type or derived from 5225 -- one, the bounds are not static. 5226 5227 if Is_Generic_Type (Root_Type (Ityp)) then 5228 OK := False; 5229 return; 5230 end if; 5231 5232 Determine_Range 5233 (Type_Low_Bound (Ityp), OK1, LL, LU, Assume_Valid); 5234 5235 if OK1 then 5236 Determine_Range 5237 (Type_High_Bound (Ityp), OK1, UL, UU, Assume_Valid); 5238 5239 if OK1 then 5240 -- The maximum value for Length is the biggest 5241 -- possible gap between the values of the bounds. 5242 -- But of course, this value cannot be negative. 5243 5244 Hir := UI_Max (Uint_0, UU - LL + 1); 5245 5246 -- For a constrained array, the minimum value for 5247 -- Length is taken from the actual value of the 5248 -- bounds, since the index will be exactly of this 5249 -- subtype. 5250 5251 if Is_Constrained (Ptyp) then 5252 Lor := UI_Max (Uint_0, UL - LU + 1); 5253 5254 -- For an unconstrained array, the minimum value 5255 -- for length is always zero. 5256 5257 else 5258 Lor := Uint_0; 5259 end if; 5260 end if; 5261 end if; 5262 5263 -- Small optimization: the maximum size in storage units 5264 -- an object can have with GNAT is half of the address 5265 -- space, so we can bound the length of an array declared 5266 -- in Interfaces (or its children) because its component 5267 -- size is at least the storage unit and it is meant to 5268 -- be used to interface actual array objects. 5269 5270 if Is_Array_Type (Ptyp) then 5271 declare 5272 S : constant Entity_Id := Scope (Base_Type (Ptyp)); 5273 begin 5274 if Is_RTU (S, Interfaces) 5275 or else (S /= Standard_Standard 5276 and then Is_RTU (Scope (S), Interfaces)) 5277 then 5278 Hir := UI_Min (Hir, Half_Address_Space); 5279 end if; 5280 end; 5281 end if; 5282 end; 5283 5284 -- The maximum default alignment is quite low, but GNAT accepts 5285 -- alignment clauses that are fairly large, but not as large as 5286 -- the maximum size of objects, see below. 5287 5288 when Attribute_Alignment => 5289 Lor := Uint_0; 5290 Hir := Half_Address_Space; 5291 OK1 := True; 5292 5293 -- The attribute should have been folded if a component clause 5294 -- was specified, so we assume there is none. 5295 5296 when Attribute_Bit 5297 | Attribute_First_Bit 5298 => 5299 Lor := Uint_0; 5300 Hir := UI_From_Int (System_Storage_Unit - 1); 5301 OK1 := True; 5302 5303 -- Likewise about the component clause. Note that Last_Bit 5304 -- yields -1 for a field of size 0 if First_Bit is 0. 5305 5306 when Attribute_Last_Bit => 5307 Lor := Uint_Minus_1; 5308 Hir := Hi; 5309 OK1 := True; 5310 5311 -- Likewise about the component clause for Position. The 5312 -- maximum size in storage units that an object can have 5313 -- with GNAT is half of the address space. 5314 5315 when Attribute_Max_Size_In_Storage_Elements 5316 | Attribute_Position 5317 => 5318 Lor := Uint_0; 5319 Hir := Half_Address_Space; 5320 OK1 := True; 5321 5322 -- These attributes yield a nonnegative value (we do not set 5323 -- the maximum value because it is too large to be useful). 5324 5325 when Attribute_Bit_Position 5326 | Attribute_Component_Size 5327 | Attribute_Object_Size 5328 | Attribute_Size 5329 | Attribute_Value_Size 5330 => 5331 Lor := Uint_0; 5332 Hir := Hi; 5333 OK1 := True; 5334 5335 -- The maximum size is the sum of twice the size of the largest 5336 -- integer for every dimension, rounded up to the next multiple 5337 -- of the maximum alignment, but we add instead of rounding. 5338 5339 when Attribute_Descriptor_Size => 5340 declare 5341 Max_Align : constant Pos := 5342 Maximum_Alignment * System_Storage_Unit; 5343 Max_Size : constant Uint := 5344 2 * Esize (Universal_Integer); 5345 Ndims : constant Pos := 5346 Number_Dimensions (Etype (Prefix (N))); 5347 begin 5348 Lor := Uint_0; 5349 Hir := Max_Size * Ndims + Max_Align; 5350 OK1 := True; 5351 end; 5352 5353 -- No special handling for other attributes 5354 -- Probably more opportunities exist here??? 5355 5356 when others => 5357 OK1 := False; 5358 5359 end case; 5360 5361 when N_Type_Conversion => 5362 -- For a type conversion, we can try to refine the range using the 5363 -- converted value. 5364 5365 Determine_Range_To_Discrete 5366 (Expression (N), OK1, Lor, Hir, Conversion_OK (N), Assume_Valid); 5367 5368 -- Nothing special to do for all other expression kinds 5369 5370 when others => 5371 OK1 := False; 5372 Lor := No_Uint; 5373 Hir := No_Uint; 5374 end case; 5375 5376 -- At this stage, if OK1 is true, then we know that the actual result of 5377 -- the computed expression is in the range Lor .. Hir. We can use this 5378 -- to restrict the possible range of results. 5379 5380 if OK1 then 5381 5382 -- If the refined value of the low bound is greater than the type 5383 -- low bound, then reset it to the more restrictive value. However, 5384 -- we do NOT do this for the case of a modular type where the 5385 -- possible upper bound on the value is above the base type high 5386 -- bound, because that means the result could wrap. 5387 5388 if Lor > Lo 5389 and then not (Is_Modular_Integer_Type (Typ) and then Hir > Hbound) 5390 then 5391 Lo := Lor; 5392 end if; 5393 5394 -- Similarly, if the refined value of the high bound is less than the 5395 -- value so far, then reset it to the more restrictive value. Again, 5396 -- we do not do this if the refined low bound is negative for a 5397 -- modular type, since this would wrap. 5398 5399 if Hir < Hi 5400 and then not (Is_Modular_Integer_Type (Typ) and then Lor < Uint_0) 5401 then 5402 Hi := Hir; 5403 end if; 5404 end if; 5405 5406 -- Set cache entry for future call and we are all done 5407 5408 Determine_Range_Cache_N (Cindex) := N; 5409 Determine_Range_Cache_O (Cindex) := Original_Node (N); 5410 Determine_Range_Cache_V (Cindex) := Assume_Valid; 5411 Determine_Range_Cache_Lo (Cindex) := Lo; 5412 Determine_Range_Cache_Hi (Cindex) := Hi; 5413 return; 5414 5415 -- If any exception occurs, it means that we have some bug in the compiler, 5416 -- possibly triggered by a previous error, or by some unforeseen peculiar 5417 -- occurrence. However, this is only an optimization attempt, so there is 5418 -- really no point in crashing the compiler. Instead we just decide, too 5419 -- bad, we can't figure out a range in this case after all. 5420 5421 exception 5422 when others => 5423 5424 -- Debug flag K disables this behavior (useful for debugging) 5425 5426 if Debug_Flag_K then 5427 raise; 5428 else 5429 OK := False; 5430 Lo := No_Uint; 5431 Hi := No_Uint; 5432 return; 5433 end if; 5434 end Determine_Range; 5435 5436 ----------------------- 5437 -- Determine_Range_R -- 5438 ----------------------- 5439 5440 procedure Determine_Range_R 5441 (N : Node_Id; 5442 OK : out Boolean; 5443 Lo : out Ureal; 5444 Hi : out Ureal; 5445 Assume_Valid : Boolean := False) 5446 is 5447 Typ : Entity_Id := Etype (N); 5448 -- Type to use, may get reset to base type for possibly invalid entity 5449 5450 Lo_Left : Ureal; 5451 Hi_Left : Ureal; 5452 -- Lo and Hi bounds of left operand 5453 5454 Lo_Right : Ureal := No_Ureal; 5455 Hi_Right : Ureal := No_Ureal; 5456 -- Lo and Hi bounds of right (or only) operand 5457 5458 Bound : Node_Id; 5459 -- Temp variable used to hold a bound node 5460 5461 Hbound : Ureal; 5462 -- High bound of base type of expression 5463 5464 Lor : Ureal; 5465 Hir : Ureal; 5466 -- Refined values for low and high bounds, after tightening 5467 5468 OK1 : Boolean; 5469 -- Used in lower level calls to indicate if call succeeded 5470 5471 Cindex : Cache_Index; 5472 -- Used to search cache 5473 5474 Btyp : Entity_Id; 5475 -- Base type 5476 5477 function OK_Operands return Boolean; 5478 -- Used for binary operators. Determines the ranges of the left and 5479 -- right operands, and if they are both OK, returns True, and puts 5480 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left. 5481 5482 function Round_Machine (B : Ureal) return Ureal; 5483 -- B is a real bound. Round it using mode Round_Even. 5484 5485 ----------------- 5486 -- OK_Operands -- 5487 ----------------- 5488 5489 function OK_Operands return Boolean is 5490 begin 5491 Determine_Range_R 5492 (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid); 5493 5494 if not OK1 then 5495 return False; 5496 end if; 5497 5498 Determine_Range_R 5499 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid); 5500 return OK1; 5501 end OK_Operands; 5502 5503 ------------------- 5504 -- Round_Machine -- 5505 ------------------- 5506 5507 function Round_Machine (B : Ureal) return Ureal is 5508 begin 5509 return Machine (Typ, B, Round_Even, N); 5510 end Round_Machine; 5511 5512 -- Start of processing for Determine_Range_R 5513 5514 begin 5515 -- Prevent junk warnings by initializing range variables 5516 5517 Lo := No_Ureal; 5518 Hi := No_Ureal; 5519 Lor := No_Ureal; 5520 Hir := No_Ureal; 5521 5522 -- For temporary constants internally generated to remove side effects 5523 -- we must use the corresponding expression to determine the range of 5524 -- the expression. But note that the expander can also generate 5525 -- constants in other cases, including deferred constants. 5526 5527 if Is_Entity_Name (N) 5528 and then Nkind (Parent (Entity (N))) = N_Object_Declaration 5529 and then Ekind (Entity (N)) = E_Constant 5530 and then Is_Internal_Name (Chars (Entity (N))) 5531 then 5532 if Present (Expression (Parent (Entity (N)))) then 5533 Determine_Range_R 5534 (Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid); 5535 5536 elsif Present (Full_View (Entity (N))) then 5537 Determine_Range_R 5538 (Expression (Parent (Full_View (Entity (N)))), 5539 OK, Lo, Hi, Assume_Valid); 5540 5541 else 5542 OK := False; 5543 end if; 5544 5545 return; 5546 end if; 5547 5548 -- If type is not defined, we can't determine its range 5549 5550 if No (Typ) 5551 5552 -- We don't deal with anything except IEEE floating-point types 5553 5554 or else not Is_Floating_Point_Type (Typ) 5555 or else Float_Rep (Typ) /= IEEE_Binary 5556 5557 -- Ignore type for which an error has been posted, since range in 5558 -- this case may well be a bogosity deriving from the error. Also 5559 -- ignore if error posted on the reference node. 5560 5561 or else Error_Posted (N) or else Error_Posted (Typ) 5562 then 5563 OK := False; 5564 return; 5565 end if; 5566 5567 -- For all other cases, we can determine the range 5568 5569 OK := True; 5570 5571 -- If value is compile time known, then the possible range is the one 5572 -- value that we know this expression definitely has. 5573 5574 if Compile_Time_Known_Value (N) then 5575 Lo := Expr_Value_R (N); 5576 Hi := Lo; 5577 return; 5578 end if; 5579 5580 -- Return if already in the cache 5581 5582 Cindex := Cache_Index (N mod Cache_Size); 5583 5584 if Determine_Range_Cache_N (Cindex) = N 5585 and then 5586 Determine_Range_Cache_O (Cindex) = Original_Node (N) 5587 and then 5588 Determine_Range_Cache_V (Cindex) = Assume_Valid 5589 then 5590 Lo := Determine_Range_Cache_Lo_R (Cindex); 5591 Hi := Determine_Range_Cache_Hi_R (Cindex); 5592 return; 5593 end if; 5594 5595 -- Otherwise, start by finding the bounds of the type of the expression, 5596 -- the value cannot be outside this range (if it is, then we have an 5597 -- overflow situation, which is a separate check, we are talking here 5598 -- only about the expression value). 5599 5600 -- First a check, never try to find the bounds of a generic type, since 5601 -- these bounds are always junk values, and it is only valid to look at 5602 -- the bounds in an instance. 5603 5604 if Is_Generic_Type (Typ) then 5605 OK := False; 5606 return; 5607 end if; 5608 5609 -- First step, change to use base type unless we know the value is valid 5610 5611 if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N))) 5612 or else Assume_No_Invalid_Values 5613 or else Assume_Valid 5614 then 5615 null; 5616 else 5617 Typ := Underlying_Type (Base_Type (Typ)); 5618 end if; 5619 5620 -- Retrieve the base type. Handle the case where the base type is a 5621 -- private type. 5622 5623 Btyp := Base_Type (Typ); 5624 5625 if Is_Private_Type (Btyp) and then Present (Full_View (Btyp)) then 5626 Btyp := Full_View (Btyp); 5627 end if; 5628 5629 -- We use the actual bound unless it is dynamic, in which case use the 5630 -- corresponding base type bound if possible. If we can't get a bound 5631 -- then we figure we can't determine the range (a peculiar case, that 5632 -- perhaps cannot happen, but there is no point in bombing in this 5633 -- optimization circuit). 5634 5635 -- First the low bound 5636 5637 Bound := Type_Low_Bound (Typ); 5638 5639 if Compile_Time_Known_Value (Bound) then 5640 Lo := Expr_Value_R (Bound); 5641 5642 elsif Compile_Time_Known_Value (Type_Low_Bound (Btyp)) then 5643 Lo := Expr_Value_R (Type_Low_Bound (Btyp)); 5644 5645 else 5646 OK := False; 5647 return; 5648 end if; 5649 5650 -- Now the high bound 5651 5652 Bound := Type_High_Bound (Typ); 5653 5654 -- We need the high bound of the base type later on, and this should 5655 -- always be compile time known. Again, it is not clear that this 5656 -- can ever be false, but no point in bombing. 5657 5658 if Compile_Time_Known_Value (Type_High_Bound (Btyp)) then 5659 Hbound := Expr_Value_R (Type_High_Bound (Btyp)); 5660 Hi := Hbound; 5661 5662 else 5663 OK := False; 5664 return; 5665 end if; 5666 5667 -- If we have a static subtype, then that may have a tighter bound so 5668 -- use the upper bound of the subtype instead in this case. 5669 5670 if Compile_Time_Known_Value (Bound) then 5671 Hi := Expr_Value_R (Bound); 5672 end if; 5673 5674 -- We may be able to refine this value in certain situations. If any 5675 -- refinement is possible, then Lor and Hir are set to possibly tighter 5676 -- bounds, and OK1 is set to True. 5677 5678 case Nkind (N) is 5679 5680 -- For unary plus, result is limited by range of operand 5681 5682 when N_Op_Plus => 5683 Determine_Range_R 5684 (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid); 5685 5686 -- For unary minus, determine range of operand, and negate it 5687 5688 when N_Op_Minus => 5689 Determine_Range_R 5690 (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid); 5691 5692 if OK1 then 5693 Lor := -Hi_Right; 5694 Hir := -Lo_Right; 5695 end if; 5696 5697 -- For binary addition, get range of each operand and do the 5698 -- addition to get the result range. 5699 5700 when N_Op_Add => 5701 if OK_Operands then 5702 Lor := Round_Machine (Lo_Left + Lo_Right); 5703 Hir := Round_Machine (Hi_Left + Hi_Right); 5704 end if; 5705 5706 -- For binary subtraction, get range of each operand and do the worst 5707 -- case subtraction to get the result range. 5708 5709 when N_Op_Subtract => 5710 if OK_Operands then 5711 Lor := Round_Machine (Lo_Left - Hi_Right); 5712 Hir := Round_Machine (Hi_Left - Lo_Right); 5713 end if; 5714 5715 -- For multiplication, get range of each operand and do the 5716 -- four multiplications to get the result range. 5717 5718 when N_Op_Multiply => 5719 if OK_Operands then 5720 declare 5721 M1 : constant Ureal := Round_Machine (Lo_Left * Lo_Right); 5722 M2 : constant Ureal := Round_Machine (Lo_Left * Hi_Right); 5723 M3 : constant Ureal := Round_Machine (Hi_Left * Lo_Right); 5724 M4 : constant Ureal := Round_Machine (Hi_Left * Hi_Right); 5725 5726 begin 5727 Lor := UR_Min (UR_Min (M1, M2), UR_Min (M3, M4)); 5728 Hir := UR_Max (UR_Max (M1, M2), UR_Max (M3, M4)); 5729 end; 5730 end if; 5731 5732 -- For division, consider separately the cases where the right 5733 -- operand is positive or negative. Otherwise, the right operand 5734 -- can be arbitrarily close to zero, so the result is likely to 5735 -- be unbounded in one direction, do not attempt to compute it. 5736 5737 when N_Op_Divide => 5738 if OK_Operands then 5739 5740 -- Right operand is positive 5741 5742 if Lo_Right > Ureal_0 then 5743 5744 -- If the low bound of the left operand is negative, obtain 5745 -- the overall low bound by dividing it by the smallest 5746 -- value of the right operand, and otherwise by the largest 5747 -- value of the right operand. 5748 5749 if Lo_Left < Ureal_0 then 5750 Lor := Round_Machine (Lo_Left / Lo_Right); 5751 else 5752 Lor := Round_Machine (Lo_Left / Hi_Right); 5753 end if; 5754 5755 -- If the high bound of the left operand is negative, obtain 5756 -- the overall high bound by dividing it by the largest 5757 -- value of the right operand, and otherwise by the 5758 -- smallest value of the right operand. 5759 5760 if Hi_Left < Ureal_0 then 5761 Hir := Round_Machine (Hi_Left / Hi_Right); 5762 else 5763 Hir := Round_Machine (Hi_Left / Lo_Right); 5764 end if; 5765 5766 -- Right operand is negative 5767 5768 elsif Hi_Right < Ureal_0 then 5769 5770 -- If the low bound of the left operand is negative, obtain 5771 -- the overall low bound by dividing it by the largest 5772 -- value of the right operand, and otherwise by the smallest 5773 -- value of the right operand. 5774 5775 if Lo_Left < Ureal_0 then 5776 Lor := Round_Machine (Lo_Left / Hi_Right); 5777 else 5778 Lor := Round_Machine (Lo_Left / Lo_Right); 5779 end if; 5780 5781 -- If the high bound of the left operand is negative, obtain 5782 -- the overall high bound by dividing it by the smallest 5783 -- value of the right operand, and otherwise by the 5784 -- largest value of the right operand. 5785 5786 if Hi_Left < Ureal_0 then 5787 Hir := Round_Machine (Hi_Left / Lo_Right); 5788 else 5789 Hir := Round_Machine (Hi_Left / Hi_Right); 5790 end if; 5791 5792 else 5793 OK1 := False; 5794 end if; 5795 end if; 5796 5797 when N_Type_Conversion => 5798 5799 -- For type conversion from one floating-point type to another, we 5800 -- can refine the range using the converted value. 5801 5802 if Is_Floating_Point_Type (Etype (Expression (N))) then 5803 Determine_Range_R (Expression (N), OK1, Lor, Hir, Assume_Valid); 5804 5805 -- When converting an integer to a floating-point type, determine 5806 -- the range in integer first, and then convert the bounds. 5807 5808 elsif Is_Discrete_Type (Etype (Expression (N))) then 5809 declare 5810 Hir_Int : Uint; 5811 Lor_Int : Uint; 5812 5813 begin 5814 Determine_Range 5815 (Expression (N), OK1, Lor_Int, Hir_Int, Assume_Valid); 5816 5817 if OK1 then 5818 Lor := Round_Machine (UR_From_Uint (Lor_Int)); 5819 Hir := Round_Machine (UR_From_Uint (Hir_Int)); 5820 end if; 5821 end; 5822 5823 else 5824 OK1 := False; 5825 end if; 5826 5827 -- Nothing special to do for all other expression kinds 5828 5829 when others => 5830 OK1 := False; 5831 Lor := No_Ureal; 5832 Hir := No_Ureal; 5833 end case; 5834 5835 -- At this stage, if OK1 is true, then we know that the actual result of 5836 -- the computed expression is in the range Lor .. Hir. We can use this 5837 -- to restrict the possible range of results. 5838 5839 if OK1 then 5840 5841 -- If the refined value of the low bound is greater than the type 5842 -- low bound, then reset it to the more restrictive value. 5843 5844 if Lor > Lo then 5845 Lo := Lor; 5846 end if; 5847 5848 -- Similarly, if the refined value of the high bound is less than the 5849 -- value so far, then reset it to the more restrictive value. 5850 5851 if Hir < Hi then 5852 Hi := Hir; 5853 end if; 5854 end if; 5855 5856 -- Set cache entry for future call and we are all done 5857 5858 Determine_Range_Cache_N (Cindex) := N; 5859 Determine_Range_Cache_O (Cindex) := Original_Node (N); 5860 Determine_Range_Cache_V (Cindex) := Assume_Valid; 5861 Determine_Range_Cache_Lo_R (Cindex) := Lo; 5862 Determine_Range_Cache_Hi_R (Cindex) := Hi; 5863 return; 5864 5865 -- If any exception occurs, it means that we have some bug in the compiler, 5866 -- possibly triggered by a previous error, or by some unforeseen peculiar 5867 -- occurrence. However, this is only an optimization attempt, so there is 5868 -- really no point in crashing the compiler. Instead we just decide, too 5869 -- bad, we can't figure out a range in this case after all. 5870 5871 exception 5872 when others => 5873 5874 -- Debug flag K disables this behavior (useful for debugging) 5875 5876 if Debug_Flag_K then 5877 raise; 5878 else 5879 OK := False; 5880 Lo := No_Ureal; 5881 Hi := No_Ureal; 5882 return; 5883 end if; 5884 end Determine_Range_R; 5885 5886 --------------------------------- 5887 -- Determine_Range_To_Discrete -- 5888 --------------------------------- 5889 5890 procedure Determine_Range_To_Discrete 5891 (N : Node_Id; 5892 OK : out Boolean; 5893 Lo : out Uint; 5894 Hi : out Uint; 5895 Fixed_Int : Boolean := False; 5896 Assume_Valid : Boolean := False) 5897 is 5898 Typ : constant Entity_Id := Etype (N); 5899 5900 begin 5901 -- For a discrete type, simply defer to Determine_Range 5902 5903 if Is_Discrete_Type (Typ) then 5904 Determine_Range (N, OK, Lo, Hi, Assume_Valid); 5905 5906 -- For a fixed point type treated as an integer, we can determine the 5907 -- range using the Corresponding_Integer_Value of the bounds of the 5908 -- type or base type. This is done by the calls to Expr_Value below. 5909 5910 elsif Is_Fixed_Point_Type (Typ) and then Fixed_Int then 5911 declare 5912 Btyp, Ftyp : Entity_Id; 5913 Bound : Node_Id; 5914 5915 begin 5916 if Assume_Valid then 5917 Ftyp := Typ; 5918 else 5919 Ftyp := Underlying_Type (Base_Type (Typ)); 5920 end if; 5921 5922 Btyp := Base_Type (Ftyp); 5923 5924 -- First the low bound 5925 5926 Bound := Type_Low_Bound (Ftyp); 5927 5928 if Compile_Time_Known_Value (Bound) then 5929 Lo := Expr_Value (Bound); 5930 else 5931 Lo := Expr_Value (Type_Low_Bound (Btyp)); 5932 end if; 5933 5934 -- Then the high bound 5935 5936 Bound := Type_High_Bound (Ftyp); 5937 5938 if Compile_Time_Known_Value (Bound) then 5939 Hi := Expr_Value (Bound); 5940 else 5941 Hi := Expr_Value (Type_High_Bound (Btyp)); 5942 end if; 5943 5944 OK := True; 5945 end; 5946 5947 -- For a floating-point type, we can determine the range in real first, 5948 -- and then convert the bounds using UR_To_Uint, which correctly rounds 5949 -- away from zero when half way between two integers, as required by 5950 -- normal Ada 95 rounding semantics. But this is only possible because 5951 -- GNATprove's analysis rules out the possibility of a NaN or infinite. 5952 5953 elsif GNATprove_Mode and then Is_Floating_Point_Type (Typ) then 5954 declare 5955 Lo_Real, Hi_Real : Ureal; 5956 5957 begin 5958 Determine_Range_R (N, OK, Lo_Real, Hi_Real, Assume_Valid); 5959 5960 if OK then 5961 Lo := UR_To_Uint (Lo_Real); 5962 Hi := UR_To_Uint (Hi_Real); 5963 else 5964 Lo := No_Uint; 5965 Hi := No_Uint; 5966 end if; 5967 end; 5968 5969 else 5970 Lo := No_Uint; 5971 Hi := No_Uint; 5972 OK := False; 5973 end if; 5974 end Determine_Range_To_Discrete; 5975 5976 ------------------------------------ 5977 -- Discriminant_Checks_Suppressed -- 5978 ------------------------------------ 5979 5980 function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is 5981 begin 5982 if Present (E) then 5983 if Is_Unchecked_Union (E) then 5984 return True; 5985 elsif Checks_May_Be_Suppressed (E) then 5986 return Is_Check_Suppressed (E, Discriminant_Check); 5987 end if; 5988 end if; 5989 5990 return Scope_Suppress.Suppress (Discriminant_Check); 5991 end Discriminant_Checks_Suppressed; 5992 5993 -------------------------------- 5994 -- Division_Checks_Suppressed -- 5995 -------------------------------- 5996 5997 function Division_Checks_Suppressed (E : Entity_Id) return Boolean is 5998 begin 5999 if Present (E) and then Checks_May_Be_Suppressed (E) then 6000 return Is_Check_Suppressed (E, Division_Check); 6001 else 6002 return Scope_Suppress.Suppress (Division_Check); 6003 end if; 6004 end Division_Checks_Suppressed; 6005 6006 -------------------------------------- 6007 -- Duplicated_Tag_Checks_Suppressed -- 6008 -------------------------------------- 6009 6010 function Duplicated_Tag_Checks_Suppressed (E : Entity_Id) return Boolean is 6011 begin 6012 if Present (E) and then Checks_May_Be_Suppressed (E) then 6013 return Is_Check_Suppressed (E, Duplicated_Tag_Check); 6014 else 6015 return Scope_Suppress.Suppress (Duplicated_Tag_Check); 6016 end if; 6017 end Duplicated_Tag_Checks_Suppressed; 6018 6019 ----------------------------------- 6020 -- Elaboration_Checks_Suppressed -- 6021 ----------------------------------- 6022 6023 function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is 6024 begin 6025 -- The complication in this routine is that if we are in the dynamic 6026 -- model of elaboration, we also check All_Checks, since All_Checks 6027 -- does not set Elaboration_Check explicitly. 6028 6029 if Present (E) then 6030 if Kill_Elaboration_Checks (E) then 6031 return True; 6032 6033 elsif Checks_May_Be_Suppressed (E) then 6034 if Is_Check_Suppressed (E, Elaboration_Check) then 6035 return True; 6036 6037 elsif Dynamic_Elaboration_Checks then 6038 return Is_Check_Suppressed (E, All_Checks); 6039 6040 else 6041 return False; 6042 end if; 6043 end if; 6044 end if; 6045 6046 if Scope_Suppress.Suppress (Elaboration_Check) then 6047 return True; 6048 6049 elsif Dynamic_Elaboration_Checks then 6050 return Scope_Suppress.Suppress (All_Checks); 6051 6052 else 6053 return False; 6054 end if; 6055 end Elaboration_Checks_Suppressed; 6056 6057 --------------------------- 6058 -- Enable_Overflow_Check -- 6059 --------------------------- 6060 6061 procedure Enable_Overflow_Check (N : Node_Id) is 6062 Typ : constant Entity_Id := Base_Type (Etype (N)); 6063 Mode : constant Overflow_Mode_Type := Overflow_Check_Mode; 6064 Chk : Nat; 6065 OK : Boolean; 6066 Ent : Entity_Id; 6067 Ofs : Uint; 6068 Lo : Uint; 6069 Hi : Uint; 6070 6071 Do_Ovflow_Check : Boolean; 6072 6073 begin 6074 if Debug_Flag_CC then 6075 w ("Enable_Overflow_Check for node ", Int (N)); 6076 Write_Str (" Source location = "); 6077 wl (Sloc (N)); 6078 pg (Union_Id (N)); 6079 end if; 6080 6081 -- No check if overflow checks suppressed for type of node 6082 6083 if Overflow_Checks_Suppressed (Etype (N)) then 6084 return; 6085 6086 -- Nothing to do for unsigned integer types, which do not overflow 6087 6088 elsif Is_Modular_Integer_Type (Typ) then 6089 return; 6090 end if; 6091 6092 -- This is the point at which processing for STRICT mode diverges 6093 -- from processing for MINIMIZED/ELIMINATED modes. This divergence is 6094 -- probably more extreme that it needs to be, but what is going on here 6095 -- is that when we introduced MINIMIZED/ELIMINATED modes, we wanted 6096 -- to leave the processing for STRICT mode untouched. There were 6097 -- two reasons for this. First it avoided any incompatible change of 6098 -- behavior. Second, it guaranteed that STRICT mode continued to be 6099 -- legacy reliable. 6100 6101 -- The big difference is that in STRICT mode there is a fair amount of 6102 -- circuitry to try to avoid setting the Do_Overflow_Check flag if we 6103 -- know that no check is needed. We skip all that in the two new modes, 6104 -- since really overflow checking happens over a whole subtree, and we 6105 -- do the corresponding optimizations later on when applying the checks. 6106 6107 if Mode in Minimized_Or_Eliminated then 6108 if not (Overflow_Checks_Suppressed (Etype (N))) 6109 and then not (Is_Entity_Name (N) 6110 and then Overflow_Checks_Suppressed (Entity (N))) 6111 then 6112 Activate_Overflow_Check (N); 6113 end if; 6114 6115 if Debug_Flag_CC then 6116 w ("Minimized/Eliminated mode"); 6117 end if; 6118 6119 return; 6120 end if; 6121 6122 -- Remainder of processing is for STRICT case, and is unchanged from 6123 -- earlier versions preceding the addition of MINIMIZED/ELIMINATED. 6124 6125 -- Nothing to do if the range of the result is known OK. We skip this 6126 -- for conversions, since the caller already did the check, and in any 6127 -- case the condition for deleting the check for a type conversion is 6128 -- different. 6129 6130 if Nkind (N) /= N_Type_Conversion then 6131 Determine_Range (N, OK, Lo, Hi, Assume_Valid => True); 6132 6133 -- Note in the test below that we assume that the range is not OK 6134 -- if a bound of the range is equal to that of the type. That's not 6135 -- quite accurate but we do this for the following reasons: 6136 6137 -- a) The way that Determine_Range works, it will typically report 6138 -- the bounds of the value as being equal to the bounds of the 6139 -- type, because it either can't tell anything more precise, or 6140 -- does not think it is worth the effort to be more precise. 6141 6142 -- b) It is very unusual to have a situation in which this would 6143 -- generate an unnecessary overflow check (an example would be 6144 -- a subtype with a range 0 .. Integer'Last - 1 to which the 6145 -- literal value one is added). 6146 6147 -- c) The alternative is a lot of special casing in this routine 6148 -- which would partially duplicate Determine_Range processing. 6149 6150 if OK then 6151 Do_Ovflow_Check := True; 6152 6153 -- Note that the following checks are quite deliberately > and < 6154 -- rather than >= and <= as explained above. 6155 6156 if Lo > Expr_Value (Type_Low_Bound (Typ)) 6157 and then 6158 Hi < Expr_Value (Type_High_Bound (Typ)) 6159 then 6160 Do_Ovflow_Check := False; 6161 6162 -- Despite the comments above, it is worth dealing specially with 6163 -- division. The only case where integer division can overflow is 6164 -- (largest negative number) / (-1). So we will do an extra range 6165 -- analysis to see if this is possible. 6166 6167 elsif Nkind (N) = N_Op_Divide then 6168 Determine_Range 6169 (Left_Opnd (N), OK, Lo, Hi, Assume_Valid => True); 6170 6171 if OK and then Lo > Expr_Value (Type_Low_Bound (Typ)) then 6172 Do_Ovflow_Check := False; 6173 6174 else 6175 Determine_Range 6176 (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True); 6177 6178 if OK and then (Lo > Uint_Minus_1 6179 or else 6180 Hi < Uint_Minus_1) 6181 then 6182 Do_Ovflow_Check := False; 6183 end if; 6184 end if; 6185 6186 -- Likewise for Abs/Minus, the only case where the operation can 6187 -- overflow is when the operand is the largest negative number. 6188 6189 elsif Nkind (N) in N_Op_Abs | N_Op_Minus then 6190 Determine_Range 6191 (Right_Opnd (N), OK, Lo, Hi, Assume_Valid => True); 6192 6193 if OK and then Lo > Expr_Value (Type_Low_Bound (Typ)) then 6194 Do_Ovflow_Check := False; 6195 end if; 6196 end if; 6197 6198 -- If no overflow check required, we are done 6199 6200 if not Do_Ovflow_Check then 6201 if Debug_Flag_CC then 6202 w ("No overflow check required"); 6203 end if; 6204 6205 return; 6206 end if; 6207 end if; 6208 end if; 6209 6210 -- If not in optimizing mode, set flag and we are done. We are also done 6211 -- (and just set the flag) if the type is not a discrete type, since it 6212 -- is not worth the effort to eliminate checks for other than discrete 6213 -- types. In addition, we take this same path if we have stored the 6214 -- maximum number of checks possible already (a very unlikely situation, 6215 -- but we do not want to blow up). 6216 6217 if Optimization_Level = 0 6218 or else not Is_Discrete_Type (Etype (N)) 6219 or else Num_Saved_Checks = Saved_Checks'Last 6220 then 6221 Activate_Overflow_Check (N); 6222 6223 if Debug_Flag_CC then 6224 w ("Optimization off"); 6225 end if; 6226 6227 return; 6228 end if; 6229 6230 -- Otherwise evaluate and check the expression 6231 6232 Find_Check 6233 (Expr => N, 6234 Check_Type => 'O', 6235 Target_Type => Empty, 6236 Entry_OK => OK, 6237 Check_Num => Chk, 6238 Ent => Ent, 6239 Ofs => Ofs); 6240 6241 if Debug_Flag_CC then 6242 w ("Called Find_Check"); 6243 w (" OK = ", OK); 6244 6245 if OK then 6246 w (" Check_Num = ", Chk); 6247 w (" Ent = ", Int (Ent)); 6248 Write_Str (" Ofs = "); 6249 pid (Ofs); 6250 end if; 6251 end if; 6252 6253 -- If check is not of form to optimize, then set flag and we are done 6254 6255 if not OK then 6256 Activate_Overflow_Check (N); 6257 return; 6258 end if; 6259 6260 -- If check is already performed, then return without setting flag 6261 6262 if Chk /= 0 then 6263 if Debug_Flag_CC then 6264 w ("Check suppressed!"); 6265 end if; 6266 6267 return; 6268 end if; 6269 6270 -- Here we will make a new entry for the new check 6271 6272 Activate_Overflow_Check (N); 6273 Num_Saved_Checks := Num_Saved_Checks + 1; 6274 Saved_Checks (Num_Saved_Checks) := 6275 (Killed => False, 6276 Entity => Ent, 6277 Offset => Ofs, 6278 Check_Type => 'O', 6279 Target_Type => Empty); 6280 6281 if Debug_Flag_CC then 6282 w ("Make new entry, check number = ", Num_Saved_Checks); 6283 w (" Entity = ", Int (Ent)); 6284 Write_Str (" Offset = "); 6285 pid (Ofs); 6286 w (" Check_Type = O"); 6287 w (" Target_Type = Empty"); 6288 end if; 6289 6290 -- If we get an exception, then something went wrong, probably because of 6291 -- an error in the structure of the tree due to an incorrect program. Or 6292 -- it may be a bug in the optimization circuit. In either case the safest 6293 -- thing is simply to set the check flag unconditionally. 6294 6295 exception 6296 when others => 6297 Activate_Overflow_Check (N); 6298 6299 if Debug_Flag_CC then 6300 w (" exception occurred, overflow flag set"); 6301 end if; 6302 6303 return; 6304 end Enable_Overflow_Check; 6305 6306 ------------------------ 6307 -- Enable_Range_Check -- 6308 ------------------------ 6309 6310 procedure Enable_Range_Check (N : Node_Id) is 6311 Chk : Nat; 6312 OK : Boolean; 6313 Ent : Entity_Id; 6314 Ofs : Uint; 6315 Ttyp : Entity_Id; 6316 P : Node_Id; 6317 6318 begin 6319 -- Return if unchecked type conversion with range check killed. In this 6320 -- case we never set the flag (that's what Kill_Range_Check is about). 6321 6322 if Nkind (N) = N_Unchecked_Type_Conversion 6323 and then Kill_Range_Check (N) 6324 then 6325 return; 6326 end if; 6327 6328 -- Do not set range check flag if parent is assignment statement or 6329 -- object declaration with Suppress_Assignment_Checks flag set 6330 6331 if Nkind (Parent (N)) in N_Assignment_Statement | N_Object_Declaration 6332 and then Suppress_Assignment_Checks (Parent (N)) 6333 then 6334 return; 6335 end if; 6336 6337 -- Check for various cases where we should suppress the range check 6338 6339 -- No check if range checks suppressed for type of node 6340 6341 if Present (Etype (N)) and then Range_Checks_Suppressed (Etype (N)) then 6342 return; 6343 6344 -- No check if node is an entity name, and range checks are suppressed 6345 -- for this entity, or for the type of this entity. 6346 6347 elsif Is_Entity_Name (N) 6348 and then (Range_Checks_Suppressed (Entity (N)) 6349 or else Range_Checks_Suppressed (Etype (Entity (N)))) 6350 then 6351 return; 6352 6353 -- No checks if index of array, and index checks are suppressed for 6354 -- the array object or the type of the array. 6355 6356 elsif Nkind (Parent (N)) = N_Indexed_Component then 6357 declare 6358 Pref : constant Node_Id := Prefix (Parent (N)); 6359 begin 6360 if Is_Entity_Name (Pref) 6361 and then Index_Checks_Suppressed (Entity (Pref)) 6362 then 6363 return; 6364 elsif Index_Checks_Suppressed (Etype (Pref)) then 6365 return; 6366 end if; 6367 end; 6368 end if; 6369 6370 -- Debug trace output 6371 6372 if Debug_Flag_CC then 6373 w ("Enable_Range_Check for node ", Int (N)); 6374 Write_Str (" Source location = "); 6375 wl (Sloc (N)); 6376 pg (Union_Id (N)); 6377 end if; 6378 6379 -- If not in optimizing mode, set flag and we are done. We are also done 6380 -- (and just set the flag) if the type is not a discrete type, since it 6381 -- is not worth the effort to eliminate checks for other than discrete 6382 -- types. In addition, we take this same path if we have stored the 6383 -- maximum number of checks possible already (a very unlikely situation, 6384 -- but we do not want to blow up). 6385 6386 if Optimization_Level = 0 6387 or else No (Etype (N)) 6388 or else not Is_Discrete_Type (Etype (N)) 6389 or else Num_Saved_Checks = Saved_Checks'Last 6390 then 6391 Activate_Range_Check (N); 6392 6393 if Debug_Flag_CC then 6394 w ("Optimization off"); 6395 end if; 6396 6397 return; 6398 end if; 6399 6400 -- Otherwise find out the target type 6401 6402 P := Parent (N); 6403 6404 -- For assignment, use left side subtype 6405 6406 if Nkind (P) = N_Assignment_Statement 6407 and then Expression (P) = N 6408 then 6409 Ttyp := Etype (Name (P)); 6410 6411 -- For indexed component, use subscript subtype 6412 6413 elsif Nkind (P) = N_Indexed_Component then 6414 declare 6415 Atyp : Entity_Id; 6416 Indx : Node_Id; 6417 Subs : Node_Id; 6418 6419 begin 6420 Atyp := Etype (Prefix (P)); 6421 6422 if Is_Access_Type (Atyp) then 6423 Atyp := Designated_Type (Atyp); 6424 6425 -- If the prefix is an access to an unconstrained array, 6426 -- perform check unconditionally: it depends on the bounds of 6427 -- an object and we cannot currently recognize whether the test 6428 -- may be redundant. 6429 6430 if not Is_Constrained (Atyp) then 6431 Activate_Range_Check (N); 6432 return; 6433 end if; 6434 6435 -- Ditto if prefix is simply an unconstrained array. We used 6436 -- to think this case was OK, if the prefix was not an explicit 6437 -- dereference, but we have now seen a case where this is not 6438 -- true, so it is safer to just suppress the optimization in this 6439 -- case. The back end is getting better at eliminating redundant 6440 -- checks in any case, so the loss won't be important. 6441 6442 elsif Is_Array_Type (Atyp) 6443 and then not Is_Constrained (Atyp) 6444 then 6445 Activate_Range_Check (N); 6446 return; 6447 end if; 6448 6449 Indx := First_Index (Atyp); 6450 Subs := First (Expressions (P)); 6451 loop 6452 if Subs = N then 6453 Ttyp := Etype (Indx); 6454 exit; 6455 end if; 6456 6457 Next_Index (Indx); 6458 Next (Subs); 6459 end loop; 6460 end; 6461 6462 -- For now, ignore all other cases, they are not so interesting 6463 6464 else 6465 if Debug_Flag_CC then 6466 w (" target type not found, flag set"); 6467 end if; 6468 6469 Activate_Range_Check (N); 6470 return; 6471 end if; 6472 6473 -- Evaluate and check the expression 6474 6475 Find_Check 6476 (Expr => N, 6477 Check_Type => 'R', 6478 Target_Type => Ttyp, 6479 Entry_OK => OK, 6480 Check_Num => Chk, 6481 Ent => Ent, 6482 Ofs => Ofs); 6483 6484 if Debug_Flag_CC then 6485 w ("Called Find_Check"); 6486 w ("Target_Typ = ", Int (Ttyp)); 6487 w (" OK = ", OK); 6488 6489 if OK then 6490 w (" Check_Num = ", Chk); 6491 w (" Ent = ", Int (Ent)); 6492 Write_Str (" Ofs = "); 6493 pid (Ofs); 6494 end if; 6495 end if; 6496 6497 -- If check is not of form to optimize, then set flag and we are done 6498 6499 if not OK then 6500 if Debug_Flag_CC then 6501 w (" expression not of optimizable type, flag set"); 6502 end if; 6503 6504 Activate_Range_Check (N); 6505 return; 6506 end if; 6507 6508 -- If check is already performed, then return without setting flag 6509 6510 if Chk /= 0 then 6511 if Debug_Flag_CC then 6512 w ("Check suppressed!"); 6513 end if; 6514 6515 return; 6516 end if; 6517 6518 -- Here we will make a new entry for the new check 6519 6520 Activate_Range_Check (N); 6521 Num_Saved_Checks := Num_Saved_Checks + 1; 6522 Saved_Checks (Num_Saved_Checks) := 6523 (Killed => False, 6524 Entity => Ent, 6525 Offset => Ofs, 6526 Check_Type => 'R', 6527 Target_Type => Ttyp); 6528 6529 if Debug_Flag_CC then 6530 w ("Make new entry, check number = ", Num_Saved_Checks); 6531 w (" Entity = ", Int (Ent)); 6532 Write_Str (" Offset = "); 6533 pid (Ofs); 6534 w (" Check_Type = R"); 6535 w (" Target_Type = ", Int (Ttyp)); 6536 pg (Union_Id (Ttyp)); 6537 end if; 6538 6539 -- If we get an exception, then something went wrong, probably because of 6540 -- an error in the structure of the tree due to an incorrect program. Or 6541 -- it may be a bug in the optimization circuit. In either case the safest 6542 -- thing is simply to set the check flag unconditionally. 6543 6544 exception 6545 when others => 6546 Activate_Range_Check (N); 6547 6548 if Debug_Flag_CC then 6549 w (" exception occurred, range flag set"); 6550 end if; 6551 6552 return; 6553 end Enable_Range_Check; 6554 6555 ------------------ 6556 -- Ensure_Valid -- 6557 ------------------ 6558 6559 procedure Ensure_Valid 6560 (Expr : Node_Id; 6561 Holes_OK : Boolean := False; 6562 Related_Id : Entity_Id := Empty; 6563 Is_Low_Bound : Boolean := False; 6564 Is_High_Bound : Boolean := False) 6565 is 6566 Typ : constant Entity_Id := Etype (Expr); 6567 6568 begin 6569 -- Ignore call if we are not doing any validity checking 6570 6571 if not Validity_Checks_On then 6572 return; 6573 6574 -- Ignore call if range or validity checks suppressed on entity or type 6575 6576 elsif Range_Or_Validity_Checks_Suppressed (Expr) then 6577 return; 6578 6579 -- No check required if expression is from the expander, we assume the 6580 -- expander will generate whatever checks are needed. Note that this is 6581 -- not just an optimization, it avoids infinite recursions. 6582 6583 -- Unchecked conversions must be checked, unless they are initialized 6584 -- scalar values, as in a component assignment in an init proc. 6585 6586 -- In addition, we force a check if Force_Validity_Checks is set 6587 6588 elsif not Comes_From_Source (Expr) 6589 and then not 6590 (Nkind (Expr) = N_Identifier 6591 and then Present (Renamed_Object (Entity (Expr))) 6592 and then Comes_From_Source (Renamed_Object (Entity (Expr)))) 6593 and then not Force_Validity_Checks 6594 and then (Nkind (Expr) /= N_Unchecked_Type_Conversion 6595 or else Kill_Range_Check (Expr)) 6596 then 6597 return; 6598 6599 -- No check required if expression is known to have valid value 6600 6601 elsif Expr_Known_Valid (Expr) then 6602 return; 6603 6604 -- No check needed within a generated predicate function. Validity 6605 -- of input value will have been checked earlier. 6606 6607 elsif Ekind (Current_Scope) = E_Function 6608 and then Is_Predicate_Function (Current_Scope) 6609 then 6610 return; 6611 6612 -- Ignore case of enumeration with holes where the flag is set not to 6613 -- worry about holes, since no special validity check is needed 6614 6615 elsif Is_Enumeration_Type (Typ) 6616 and then Has_Non_Standard_Rep (Typ) 6617 and then Holes_OK 6618 then 6619 return; 6620 6621 -- No check required on the left-hand side of an assignment 6622 6623 elsif Nkind (Parent (Expr)) = N_Assignment_Statement 6624 and then Expr = Name (Parent (Expr)) 6625 then 6626 return; 6627 6628 -- No check on a universal real constant. The context will eventually 6629 -- convert it to a machine number for some target type, or report an 6630 -- illegality. 6631 6632 elsif Nkind (Expr) = N_Real_Literal 6633 and then Etype (Expr) = Universal_Real 6634 then 6635 return; 6636 6637 -- If the expression denotes a component of a packed boolean array, 6638 -- no possible check applies. We ignore the old ACATS chestnuts that 6639 -- involve Boolean range True..True. 6640 6641 -- Note: validity checks are generated for expressions that yield a 6642 -- scalar type, when it is possible to create a value that is outside of 6643 -- the type. If this is a one-bit boolean no such value exists. This is 6644 -- an optimization, and it also prevents compiler blowing up during the 6645 -- elaboration of improperly expanded packed array references. 6646 6647 elsif Nkind (Expr) = N_Indexed_Component 6648 and then Is_Bit_Packed_Array (Etype (Prefix (Expr))) 6649 and then Root_Type (Etype (Expr)) = Standard_Boolean 6650 then 6651 return; 6652 6653 -- For an expression with actions, we want to insert the validity check 6654 -- on the final Expression. 6655 6656 elsif Nkind (Expr) = N_Expression_With_Actions then 6657 Ensure_Valid (Expression (Expr)); 6658 return; 6659 6660 -- An annoying special case. If this is an out parameter of a scalar 6661 -- type, then the value is not going to be accessed, therefore it is 6662 -- inappropriate to do any validity check at the call site. Likewise 6663 -- if the parameter is passed by reference. 6664 6665 else 6666 -- Only need to worry about scalar types 6667 6668 if Is_Scalar_Type (Typ) then 6669 declare 6670 P : Node_Id; 6671 N : Node_Id; 6672 E : Entity_Id; 6673 F : Entity_Id; 6674 A : Node_Id; 6675 L : List_Id; 6676 6677 begin 6678 -- Find actual argument (which may be a parameter association) 6679 -- and the parent of the actual argument (the call statement) 6680 6681 N := Expr; 6682 P := Parent (Expr); 6683 6684 if Nkind (P) = N_Parameter_Association then 6685 N := P; 6686 P := Parent (N); 6687 end if; 6688 6689 -- If this is an indirect or dispatching call, get signature 6690 -- from the subprogram type. 6691 6692 if Nkind (P) in N_Entry_Call_Statement 6693 | N_Function_Call 6694 | N_Procedure_Call_Statement 6695 then 6696 E := Get_Called_Entity (P); 6697 L := Parameter_Associations (P); 6698 6699 -- Only need to worry if there are indeed actuals, and if 6700 -- this could be a subprogram call, otherwise we cannot get 6701 -- a match (either we are not an argument, or the mode of 6702 -- the formal is not OUT). This test also filters out the 6703 -- generic case. 6704 6705 if Is_Non_Empty_List (L) and then Is_Subprogram (E) then 6706 6707 -- This is the loop through parameters, looking for an 6708 -- OUT parameter for which we are the argument. 6709 6710 F := First_Formal (E); 6711 A := First (L); 6712 while Present (F) loop 6713 if A = N 6714 and then (Ekind (F) = E_Out_Parameter 6715 or else Mechanism (F) = By_Reference) 6716 then 6717 return; 6718 end if; 6719 6720 Next_Formal (F); 6721 Next (A); 6722 end loop; 6723 end if; 6724 end if; 6725 end; 6726 end if; 6727 end if; 6728 6729 -- If this is a boolean expression, only its elementary operands need 6730 -- checking: if they are valid, a boolean or short-circuit operation 6731 -- with them will be valid as well. 6732 6733 if Base_Type (Typ) = Standard_Boolean 6734 and then 6735 (Nkind (Expr) in N_Op or else Nkind (Expr) in N_Short_Circuit) 6736 then 6737 return; 6738 end if; 6739 6740 -- If we fall through, a validity check is required 6741 6742 Insert_Valid_Check (Expr, Related_Id, Is_Low_Bound, Is_High_Bound); 6743 6744 if Is_Entity_Name (Expr) 6745 and then Safe_To_Capture_Value (Expr, Entity (Expr)) 6746 then 6747 Set_Is_Known_Valid (Entity (Expr)); 6748 end if; 6749 end Ensure_Valid; 6750 6751 ---------------------- 6752 -- Expr_Known_Valid -- 6753 ---------------------- 6754 6755 function Expr_Known_Valid (Expr : Node_Id) return Boolean is 6756 Typ : constant Entity_Id := Etype (Expr); 6757 6758 begin 6759 -- Non-scalar types are always considered valid, since they never give 6760 -- rise to the issues of erroneous or bounded error behavior that are 6761 -- the concern. In formal reference manual terms the notion of validity 6762 -- only applies to scalar types. Note that even when packed arrays are 6763 -- represented using modular types, they are still arrays semantically, 6764 -- so they are also always valid (in particular, the unused bits can be 6765 -- random rubbish without affecting the validity of the array value). 6766 6767 if not Is_Scalar_Type (Typ) or else Is_Packed_Array_Impl_Type (Typ) then 6768 return True; 6769 6770 -- If no validity checking, then everything is considered valid 6771 6772 elsif not Validity_Checks_On then 6773 return True; 6774 6775 -- Floating-point types are considered valid unless floating-point 6776 -- validity checks have been specifically turned on. 6777 6778 elsif Is_Floating_Point_Type (Typ) 6779 and then not Validity_Check_Floating_Point 6780 then 6781 return True; 6782 6783 -- If the expression is the value of an object that is known to be 6784 -- valid, then clearly the expression value itself is valid. 6785 6786 elsif Is_Entity_Name (Expr) 6787 and then Is_Known_Valid (Entity (Expr)) 6788 6789 -- Exclude volatile variables 6790 6791 and then not Treat_As_Volatile (Entity (Expr)) 6792 then 6793 return True; 6794 6795 -- References to discriminants are always considered valid. The value 6796 -- of a discriminant gets checked when the object is built. Within the 6797 -- record, we consider it valid, and it is important to do so, since 6798 -- otherwise we can try to generate bogus validity checks which 6799 -- reference discriminants out of scope. Discriminants of concurrent 6800 -- types are excluded for the same reason. 6801 6802 elsif Is_Entity_Name (Expr) 6803 and then Denotes_Discriminant (Expr, Check_Concurrent => True) 6804 then 6805 return True; 6806 6807 -- If the type is one for which all values are known valid, then we are 6808 -- sure that the value is valid except in the slightly odd case where 6809 -- the expression is a reference to a variable whose size has been 6810 -- explicitly set to a value greater than the object size. 6811 6812 elsif Is_Known_Valid (Typ) then 6813 if Is_Entity_Name (Expr) 6814 and then Ekind (Entity (Expr)) = E_Variable 6815 and then Esize (Entity (Expr)) > Esize (Typ) 6816 then 6817 return False; 6818 else 6819 return True; 6820 end if; 6821 6822 -- Integer and character literals always have valid values, where 6823 -- appropriate these will be range checked in any case. 6824 6825 elsif Nkind (Expr) in N_Integer_Literal | N_Character_Literal then 6826 return True; 6827 6828 -- If we have a type conversion or a qualification of a known valid 6829 -- value, then the result will always be valid. 6830 6831 elsif Nkind (Expr) in N_Type_Conversion | N_Qualified_Expression then 6832 return Expr_Known_Valid (Expression (Expr)); 6833 6834 -- Case of expression is a non-floating-point operator. In this case we 6835 -- can assume the result is valid the generated code for the operator 6836 -- will include whatever checks are needed (e.g. range checks) to ensure 6837 -- validity. This assumption does not hold for the floating-point case, 6838 -- since floating-point operators can generate Infinite or NaN results 6839 -- which are considered invalid. 6840 6841 -- Historical note: in older versions, the exemption of floating-point 6842 -- types from this assumption was done only in cases where the parent 6843 -- was an assignment, function call or parameter association. Presumably 6844 -- the idea was that in other contexts, the result would be checked 6845 -- elsewhere, but this list of cases was missing tests (at least the 6846 -- N_Object_Declaration case, as shown by a reported missing validity 6847 -- check), and it is not clear why function calls but not procedure 6848 -- calls were tested for. It really seems more accurate and much 6849 -- safer to recognize that expressions which are the result of a 6850 -- floating-point operator can never be assumed to be valid. 6851 6852 elsif Nkind (Expr) in N_Op and then not Is_Floating_Point_Type (Typ) then 6853 return True; 6854 6855 -- The result of a membership test is always valid, since it is true or 6856 -- false, there are no other possibilities. 6857 6858 elsif Nkind (Expr) in N_Membership_Test then 6859 return True; 6860 6861 -- For all other cases, we do not know the expression is valid 6862 6863 else 6864 return False; 6865 end if; 6866 end Expr_Known_Valid; 6867 6868 ---------------- 6869 -- Find_Check -- 6870 ---------------- 6871 6872 procedure Find_Check 6873 (Expr : Node_Id; 6874 Check_Type : Character; 6875 Target_Type : Entity_Id; 6876 Entry_OK : out Boolean; 6877 Check_Num : out Nat; 6878 Ent : out Entity_Id; 6879 Ofs : out Uint) 6880 is 6881 function Within_Range_Of 6882 (Target_Type : Entity_Id; 6883 Check_Type : Entity_Id) return Boolean; 6884 -- Given a requirement for checking a range against Target_Type, and 6885 -- and a range Check_Type against which a check has already been made, 6886 -- determines if the check against check type is sufficient to ensure 6887 -- that no check against Target_Type is required. 6888 6889 --------------------- 6890 -- Within_Range_Of -- 6891 --------------------- 6892 6893 function Within_Range_Of 6894 (Target_Type : Entity_Id; 6895 Check_Type : Entity_Id) return Boolean 6896 is 6897 begin 6898 if Target_Type = Check_Type then 6899 return True; 6900 6901 else 6902 declare 6903 Tlo : constant Node_Id := Type_Low_Bound (Target_Type); 6904 Thi : constant Node_Id := Type_High_Bound (Target_Type); 6905 Clo : constant Node_Id := Type_Low_Bound (Check_Type); 6906 Chi : constant Node_Id := Type_High_Bound (Check_Type); 6907 6908 begin 6909 if (Tlo = Clo 6910 or else (Compile_Time_Known_Value (Tlo) 6911 and then 6912 Compile_Time_Known_Value (Clo) 6913 and then 6914 Expr_Value (Clo) >= Expr_Value (Tlo))) 6915 and then 6916 (Thi = Chi 6917 or else (Compile_Time_Known_Value (Thi) 6918 and then 6919 Compile_Time_Known_Value (Chi) 6920 and then 6921 Expr_Value (Chi) <= Expr_Value (Clo))) 6922 then 6923 return True; 6924 else 6925 return False; 6926 end if; 6927 end; 6928 end if; 6929 end Within_Range_Of; 6930 6931 -- Start of processing for Find_Check 6932 6933 begin 6934 -- Establish default, in case no entry is found 6935 6936 Check_Num := 0; 6937 6938 -- Case of expression is simple entity reference 6939 6940 if Is_Entity_Name (Expr) then 6941 Ent := Entity (Expr); 6942 Ofs := Uint_0; 6943 6944 -- Case of expression is entity + known constant 6945 6946 elsif Nkind (Expr) = N_Op_Add 6947 and then Compile_Time_Known_Value (Right_Opnd (Expr)) 6948 and then Is_Entity_Name (Left_Opnd (Expr)) 6949 then 6950 Ent := Entity (Left_Opnd (Expr)); 6951 Ofs := Expr_Value (Right_Opnd (Expr)); 6952 6953 -- Case of expression is entity - known constant 6954 6955 elsif Nkind (Expr) = N_Op_Subtract 6956 and then Compile_Time_Known_Value (Right_Opnd (Expr)) 6957 and then Is_Entity_Name (Left_Opnd (Expr)) 6958 then 6959 Ent := Entity (Left_Opnd (Expr)); 6960 Ofs := UI_Negate (Expr_Value (Right_Opnd (Expr))); 6961 6962 -- Any other expression is not of the right form 6963 6964 else 6965 Ent := Empty; 6966 Ofs := Uint_0; 6967 Entry_OK := False; 6968 return; 6969 end if; 6970 6971 -- Come here with expression of appropriate form, check if entity is an 6972 -- appropriate one for our purposes. 6973 6974 if (Ekind (Ent) = E_Variable 6975 or else Is_Constant_Object (Ent)) 6976 and then not Is_Library_Level_Entity (Ent) 6977 then 6978 Entry_OK := True; 6979 else 6980 Entry_OK := False; 6981 return; 6982 end if; 6983 6984 -- See if there is matching check already 6985 6986 for J in reverse 1 .. Num_Saved_Checks loop 6987 declare 6988 SC : Saved_Check renames Saved_Checks (J); 6989 begin 6990 if SC.Killed = False 6991 and then SC.Entity = Ent 6992 and then SC.Offset = Ofs 6993 and then SC.Check_Type = Check_Type 6994 and then Within_Range_Of (Target_Type, SC.Target_Type) 6995 then 6996 Check_Num := J; 6997 return; 6998 end if; 6999 end; 7000 end loop; 7001 7002 -- If we fall through entry was not found 7003 7004 return; 7005 end Find_Check; 7006 7007 --------------------------------- 7008 -- Generate_Discriminant_Check -- 7009 --------------------------------- 7010 7011 procedure Generate_Discriminant_Check (N : Node_Id) is 7012 Loc : constant Source_Ptr := Sloc (N); 7013 Pref : constant Node_Id := Prefix (N); 7014 Sel : constant Node_Id := Selector_Name (N); 7015 7016 Orig_Comp : constant Entity_Id := 7017 Original_Record_Component (Entity (Sel)); 7018 -- The original component to be checked 7019 7020 Discr_Fct : constant Entity_Id := 7021 Discriminant_Checking_Func (Orig_Comp); 7022 -- The discriminant checking function 7023 7024 Discr : Entity_Id; 7025 -- One discriminant to be checked in the type 7026 7027 Real_Discr : Entity_Id; 7028 -- Actual discriminant in the call 7029 7030 Pref_Type : Entity_Id; 7031 -- Type of relevant prefix (ignoring private/access stuff) 7032 7033 Args : List_Id; 7034 -- List of arguments for function call 7035 7036 Formal : Entity_Id; 7037 -- Keep track of the formal corresponding to the actual we build for 7038 -- each discriminant, in order to be able to perform the necessary type 7039 -- conversions. 7040 7041 Scomp : Node_Id; 7042 -- Selected component reference for checking function argument 7043 7044 begin 7045 Pref_Type := Etype (Pref); 7046 7047 -- Force evaluation of the prefix, so that it does not get evaluated 7048 -- twice (once for the check, once for the actual reference). Such a 7049 -- double evaluation is always a potential source of inefficiency, and 7050 -- is functionally incorrect in the volatile case, or when the prefix 7051 -- may have side effects. A nonvolatile entity or a component of a 7052 -- nonvolatile entity requires no evaluation. 7053 7054 if Is_Entity_Name (Pref) then 7055 if Treat_As_Volatile (Entity (Pref)) then 7056 Force_Evaluation (Pref, Name_Req => True); 7057 end if; 7058 7059 elsif Treat_As_Volatile (Etype (Pref)) then 7060 Force_Evaluation (Pref, Name_Req => True); 7061 7062 elsif Nkind (Pref) = N_Selected_Component 7063 and then Is_Entity_Name (Prefix (Pref)) 7064 then 7065 null; 7066 7067 else 7068 Force_Evaluation (Pref, Name_Req => True); 7069 end if; 7070 7071 -- For a tagged type, use the scope of the original component to 7072 -- obtain the type, because ??? 7073 7074 if Is_Tagged_Type (Scope (Orig_Comp)) then 7075 Pref_Type := Scope (Orig_Comp); 7076 7077 -- For an untagged derived type, use the discriminants of the parent 7078 -- which have been renamed in the derivation, possibly by a one-to-many 7079 -- discriminant constraint. For untagged type, initially get the Etype 7080 -- of the prefix 7081 7082 else 7083 if Is_Derived_Type (Pref_Type) 7084 and then Number_Discriminants (Pref_Type) /= 7085 Number_Discriminants (Etype (Base_Type (Pref_Type))) 7086 then 7087 Pref_Type := Etype (Base_Type (Pref_Type)); 7088 end if; 7089 end if; 7090 7091 -- We definitely should have a checking function, This routine should 7092 -- not be called if no discriminant checking function is present. 7093 7094 pragma Assert (Present (Discr_Fct)); 7095 7096 -- Create the list of the actual parameters for the call. This list 7097 -- is the list of the discriminant fields of the record expression to 7098 -- be discriminant checked. 7099 7100 Args := New_List; 7101 Formal := First_Formal (Discr_Fct); 7102 Discr := First_Discriminant (Pref_Type); 7103 while Present (Discr) loop 7104 7105 -- If we have a corresponding discriminant field, and a parent 7106 -- subtype is present, then we want to use the corresponding 7107 -- discriminant since this is the one with the useful value. 7108 7109 if Present (Corresponding_Discriminant (Discr)) 7110 and then Ekind (Pref_Type) = E_Record_Type 7111 and then Present (Parent_Subtype (Pref_Type)) 7112 then 7113 Real_Discr := Corresponding_Discriminant (Discr); 7114 else 7115 Real_Discr := Discr; 7116 end if; 7117 7118 -- Construct the reference to the discriminant 7119 7120 Scomp := 7121 Make_Selected_Component (Loc, 7122 Prefix => 7123 Unchecked_Convert_To (Pref_Type, 7124 Duplicate_Subexpr (Pref)), 7125 Selector_Name => New_Occurrence_Of (Real_Discr, Loc)); 7126 7127 -- Manually analyze and resolve this selected component. We really 7128 -- want it just as it appears above, and do not want the expander 7129 -- playing discriminal games etc with this reference. Then we append 7130 -- the argument to the list we are gathering. 7131 7132 Set_Etype (Scomp, Etype (Real_Discr)); 7133 Set_Analyzed (Scomp, True); 7134 Append_To (Args, Convert_To (Etype (Formal), Scomp)); 7135 7136 Next_Formal_With_Extras (Formal); 7137 Next_Discriminant (Discr); 7138 end loop; 7139 7140 -- Now build and insert the call 7141 7142 Insert_Action (N, 7143 Make_Raise_Constraint_Error (Loc, 7144 Condition => 7145 Make_Function_Call (Loc, 7146 Name => New_Occurrence_Of (Discr_Fct, Loc), 7147 Parameter_Associations => Args), 7148 Reason => CE_Discriminant_Check_Failed)); 7149 end Generate_Discriminant_Check; 7150 7151 --------------------------- 7152 -- Generate_Index_Checks -- 7153 --------------------------- 7154 7155 procedure Generate_Index_Checks (N : Node_Id) is 7156 7157 function Entity_Of_Prefix return Entity_Id; 7158 -- Returns the entity of the prefix of N (or Empty if not found) 7159 7160 ---------------------- 7161 -- Entity_Of_Prefix -- 7162 ---------------------- 7163 7164 function Entity_Of_Prefix return Entity_Id is 7165 P : Node_Id; 7166 7167 begin 7168 P := Prefix (N); 7169 while not Is_Entity_Name (P) loop 7170 if Nkind (P) not in N_Selected_Component | N_Indexed_Component then 7171 return Empty; 7172 end if; 7173 7174 P := Prefix (P); 7175 end loop; 7176 7177 return Entity (P); 7178 end Entity_Of_Prefix; 7179 7180 -- Local variables 7181 7182 Loc : constant Source_Ptr := Sloc (N); 7183 A : constant Node_Id := Prefix (N); 7184 A_Ent : constant Entity_Id := Entity_Of_Prefix; 7185 Sub : Node_Id; 7186 7187 -- Start of processing for Generate_Index_Checks 7188 7189 begin 7190 -- Ignore call if the prefix is not an array since we have a serious 7191 -- error in the sources. Ignore it also if index checks are suppressed 7192 -- for array object or type. 7193 7194 if not Is_Array_Type (Etype (A)) 7195 or else (Present (A_Ent) and then Index_Checks_Suppressed (A_Ent)) 7196 or else Index_Checks_Suppressed (Etype (A)) 7197 then 7198 return; 7199 7200 -- The indexed component we are dealing with contains 'Loop_Entry in its 7201 -- prefix. This case arises when analysis has determined that constructs 7202 -- such as 7203 7204 -- Prefix'Loop_Entry (Expr) 7205 -- Prefix'Loop_Entry (Expr1, Expr2, ... ExprN) 7206 7207 -- require rewriting for error detection purposes. A side effect of this 7208 -- action is the generation of index checks that mention 'Loop_Entry. 7209 -- Delay the generation of the check until 'Loop_Entry has been properly 7210 -- expanded. This is done in Expand_Loop_Entry_Attributes. 7211 7212 elsif Nkind (Prefix (N)) = N_Attribute_Reference 7213 and then Attribute_Name (Prefix (N)) = Name_Loop_Entry 7214 then 7215 return; 7216 end if; 7217 7218 -- Generate a raise of constraint error with the appropriate reason and 7219 -- a condition of the form: 7220 7221 -- Base_Type (Sub) not in Array'Range (Subscript) 7222 7223 -- Note that the reason we generate the conversion to the base type here 7224 -- is that we definitely want the range check to take place, even if it 7225 -- looks like the subtype is OK. Optimization considerations that allow 7226 -- us to omit the check have already been taken into account in the 7227 -- setting of the Do_Range_Check flag earlier on. 7228 7229 Sub := First (Expressions (N)); 7230 7231 -- Handle string literals 7232 7233 if Ekind (Etype (A)) = E_String_Literal_Subtype then 7234 if Do_Range_Check (Sub) then 7235 Set_Do_Range_Check (Sub, False); 7236 7237 -- For string literals we obtain the bounds of the string from the 7238 -- associated subtype. 7239 7240 Insert_Action (N, 7241 Make_Raise_Constraint_Error (Loc, 7242 Condition => 7243 Make_Not_In (Loc, 7244 Left_Opnd => 7245 Convert_To (Base_Type (Etype (Sub)), 7246 Duplicate_Subexpr_Move_Checks (Sub)), 7247 Right_Opnd => 7248 Make_Attribute_Reference (Loc, 7249 Prefix => New_Occurrence_Of (Etype (A), Loc), 7250 Attribute_Name => Name_Range)), 7251 Reason => CE_Index_Check_Failed)); 7252 end if; 7253 7254 -- General case 7255 7256 else 7257 declare 7258 A_Idx : Node_Id; 7259 A_Range : Node_Id; 7260 Ind : Pos; 7261 Num : List_Id; 7262 Range_N : Node_Id; 7263 7264 begin 7265 A_Idx := First_Index (Etype (A)); 7266 Ind := 1; 7267 while Present (Sub) loop 7268 if Do_Range_Check (Sub) then 7269 Set_Do_Range_Check (Sub, False); 7270 7271 -- Force evaluation except for the case of a simple name of 7272 -- a nonvolatile entity. 7273 7274 if not Is_Entity_Name (Sub) 7275 or else Treat_As_Volatile (Entity (Sub)) 7276 then 7277 Force_Evaluation (Sub); 7278 end if; 7279 7280 if Nkind (A_Idx) = N_Range then 7281 A_Range := A_Idx; 7282 7283 elsif Nkind (A_Idx) in N_Identifier | N_Expanded_Name then 7284 A_Range := Scalar_Range (Entity (A_Idx)); 7285 7286 if Nkind (A_Range) = N_Subtype_Indication then 7287 A_Range := Range_Expression (Constraint (A_Range)); 7288 end if; 7289 7290 else pragma Assert (Nkind (A_Idx) = N_Subtype_Indication); 7291 A_Range := Range_Expression (Constraint (A_Idx)); 7292 end if; 7293 7294 -- For array objects with constant bounds we can generate 7295 -- the index check using the bounds of the type of the index 7296 7297 if Present (A_Ent) 7298 and then Ekind (A_Ent) = E_Variable 7299 and then Is_Constant_Bound (Low_Bound (A_Range)) 7300 and then Is_Constant_Bound (High_Bound (A_Range)) 7301 then 7302 Range_N := 7303 Make_Attribute_Reference (Loc, 7304 Prefix => 7305 New_Occurrence_Of (Etype (A_Idx), Loc), 7306 Attribute_Name => Name_Range); 7307 7308 -- For arrays with non-constant bounds we cannot generate 7309 -- the index check using the bounds of the type of the index 7310 -- since it may reference discriminants of some enclosing 7311 -- type. We obtain the bounds directly from the prefix 7312 -- object. 7313 7314 else 7315 if Ind = 1 then 7316 Num := No_List; 7317 else 7318 Num := New_List (Make_Integer_Literal (Loc, Ind)); 7319 end if; 7320 7321 Range_N := 7322 Make_Attribute_Reference (Loc, 7323 Prefix => 7324 Duplicate_Subexpr_Move_Checks (A, Name_Req => True), 7325 Attribute_Name => Name_Range, 7326 Expressions => Num); 7327 end if; 7328 7329 Insert_Action (N, 7330 Make_Raise_Constraint_Error (Loc, 7331 Condition => 7332 Make_Not_In (Loc, 7333 Left_Opnd => 7334 Convert_To (Base_Type (Etype (Sub)), 7335 Duplicate_Subexpr_Move_Checks (Sub)), 7336 Right_Opnd => Range_N), 7337 Reason => CE_Index_Check_Failed)); 7338 end if; 7339 7340 Next_Index (A_Idx); 7341 Ind := Ind + 1; 7342 Next (Sub); 7343 end loop; 7344 end; 7345 end if; 7346 end Generate_Index_Checks; 7347 7348 -------------------------- 7349 -- Generate_Range_Check -- 7350 -------------------------- 7351 7352 procedure Generate_Range_Check 7353 (N : Node_Id; 7354 Target_Type : Entity_Id; 7355 Reason : RT_Exception_Code) 7356 is 7357 Loc : constant Source_Ptr := Sloc (N); 7358 Source_Type : constant Entity_Id := Etype (N); 7359 Source_Base_Type : constant Entity_Id := Base_Type (Source_Type); 7360 Target_Base_Type : constant Entity_Id := Base_Type (Target_Type); 7361 7362 procedure Convert_And_Check_Range (Suppress : Check_Id); 7363 -- Convert N to the target base type and save the result in a temporary. 7364 -- The action is analyzed using the default checks as modified by the 7365 -- given Suppress argument. Then check the converted value against the 7366 -- range of the target subtype. 7367 7368 function Is_Single_Attribute_Reference (N : Node_Id) return Boolean; 7369 -- Return True if N is an expression that contains a single attribute 7370 -- reference, possibly as operand among only integer literal operands. 7371 7372 ----------------------------- 7373 -- Convert_And_Check_Range -- 7374 ----------------------------- 7375 7376 procedure Convert_And_Check_Range (Suppress : Check_Id) is 7377 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); 7378 Conv_N : Node_Id; 7379 7380 begin 7381 -- For enumeration types with non-standard representation this is a 7382 -- direct conversion from the enumeration type to the target integer 7383 -- type, which is treated by the back end as a normal integer type 7384 -- conversion, treating the enumeration type as an integer, which is 7385 -- exactly what we want. We set Conversion_OK to make sure that the 7386 -- analyzer does not complain about what otherwise might be an 7387 -- illegal conversion. 7388 7389 if Is_Enumeration_Type (Source_Base_Type) 7390 and then Present (Enum_Pos_To_Rep (Source_Base_Type)) 7391 and then Is_Integer_Type (Target_Base_Type) 7392 then 7393 Conv_N := OK_Convert_To (Target_Base_Type, Duplicate_Subexpr (N)); 7394 else 7395 Conv_N := Convert_To (Target_Base_Type, Duplicate_Subexpr (N)); 7396 end if; 7397 7398 -- We make a temporary to hold the value of the conversion to the 7399 -- target base type, and then do the test against this temporary. 7400 -- N itself is replaced by an occurrence of Tnn and followed by 7401 -- the explicit range check. 7402 7403 -- Tnn : constant Target_Base_Type := Target_Base_Type (N); 7404 -- [constraint_error when Tnn not in Target_Type] 7405 -- Tnn 7406 7407 Insert_Actions (N, New_List ( 7408 Make_Object_Declaration (Loc, 7409 Defining_Identifier => Tnn, 7410 Object_Definition => New_Occurrence_Of (Target_Base_Type, Loc), 7411 Constant_Present => True, 7412 Expression => Conv_N), 7413 7414 Make_Raise_Constraint_Error (Loc, 7415 Condition => 7416 Make_Not_In (Loc, 7417 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 7418 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)), 7419 Reason => Reason)), 7420 Suppress => Suppress); 7421 7422 Rewrite (N, New_Occurrence_Of (Tnn, Loc)); 7423 7424 -- Set the type of N, because the declaration for Tnn might not 7425 -- be analyzed yet, as is the case if N appears within a record 7426 -- declaration, as a discriminant constraint or expression. 7427 7428 Set_Etype (N, Target_Base_Type); 7429 end Convert_And_Check_Range; 7430 7431 ------------------------------------- 7432 -- Is_Single_Attribute_Reference -- 7433 ------------------------------------- 7434 7435 function Is_Single_Attribute_Reference (N : Node_Id) return Boolean is 7436 begin 7437 if Nkind (N) = N_Attribute_Reference then 7438 return True; 7439 7440 elsif Nkind (N) in N_Binary_Op then 7441 if Nkind (Right_Opnd (N)) = N_Integer_Literal then 7442 return Is_Single_Attribute_Reference (Left_Opnd (N)); 7443 7444 elsif Nkind (Left_Opnd (N)) = N_Integer_Literal then 7445 return Is_Single_Attribute_Reference (Right_Opnd (N)); 7446 7447 else 7448 return False; 7449 end if; 7450 7451 else 7452 return False; 7453 end if; 7454 end Is_Single_Attribute_Reference; 7455 7456 -- Start of processing for Generate_Range_Check 7457 7458 begin 7459 -- First special case, if the source type is already within the range 7460 -- of the target type, then no check is needed (probably we should have 7461 -- stopped Do_Range_Check from being set in the first place, but better 7462 -- late than never in preventing junk code and junk flag settings). 7463 7464 if In_Subrange_Of (Source_Type, Target_Type) 7465 7466 -- We do NOT apply this if the source node is a literal, since in this 7467 -- case the literal has already been labeled as having the subtype of 7468 -- the target. 7469 7470 and then not 7471 (Nkind (N) in 7472 N_Integer_Literal | N_Real_Literal | N_Character_Literal 7473 or else 7474 (Is_Entity_Name (N) 7475 and then Ekind (Entity (N)) = E_Enumeration_Literal)) 7476 then 7477 Set_Do_Range_Check (N, False); 7478 return; 7479 end if; 7480 7481 -- Here a check is needed. If the expander is not active (which is also 7482 -- the case in GNATprove mode), then simply set the Do_Range_Check flag 7483 -- and we are done. We just want to see the range check flag set, we do 7484 -- not want to generate the explicit range check code. 7485 7486 if not Expander_Active then 7487 Set_Do_Range_Check (N); 7488 return; 7489 end if; 7490 7491 -- Here we will generate an explicit range check, so we don't want to 7492 -- set the Do_Range check flag, since the range check is taken care of 7493 -- by the code we will generate. 7494 7495 Set_Do_Range_Check (N, False); 7496 7497 -- Force evaluation of the node, so that it does not get evaluated twice 7498 -- (once for the check, once for the actual reference). Such a double 7499 -- evaluation is always a potential source of inefficiency, and is 7500 -- functionally incorrect in the volatile case. 7501 7502 -- We skip the evaluation of attribute references because, after these 7503 -- runtime checks are generated, the expander may need to rewrite this 7504 -- node (for example, see Attribute_Max_Size_In_Storage_Elements in 7505 -- Expand_N_Attribute_Reference) and, in many cases, their return type 7506 -- is universal integer, which is a very large type for a temporary. 7507 7508 if not Is_Single_Attribute_Reference (N) 7509 and then (not Is_Entity_Name (N) 7510 or else Treat_As_Volatile (Entity (N))) 7511 then 7512 Force_Evaluation (N, Mode => Strict); 7513 end if; 7514 7515 -- The easiest case is when Source_Base_Type and Target_Base_Type are 7516 -- the same since in this case we can simply do a direct check of the 7517 -- value of N against the bounds of Target_Type. 7518 7519 -- [constraint_error when N not in Target_Type] 7520 7521 -- Note: this is by far the most common case, for example all cases of 7522 -- checks on the RHS of assignments are in this category, but not all 7523 -- cases are like this. Notably conversions can involve two types. 7524 7525 if Source_Base_Type = Target_Base_Type then 7526 7527 -- Insert the explicit range check. Note that we suppress checks for 7528 -- this code, since we don't want a recursive range check popping up. 7529 7530 Insert_Action (N, 7531 Make_Raise_Constraint_Error (Loc, 7532 Condition => 7533 Make_Not_In (Loc, 7534 Left_Opnd => Duplicate_Subexpr (N), 7535 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)), 7536 Reason => Reason), 7537 Suppress => All_Checks); 7538 7539 -- Next test for the case where the target type is within the bounds 7540 -- of the base type of the source type, since in this case we can 7541 -- simply convert the bounds of the target type to this base type 7542 -- to do the test. 7543 7544 -- [constraint_error when N not in 7545 -- Source_Base_Type (Target_Type'First) 7546 -- .. 7547 -- Source_Base_Type(Target_Type'Last))] 7548 7549 -- The conversions will always work and need no check 7550 7551 -- Unchecked_Convert_To is used instead of Convert_To to handle the case 7552 -- of converting from an enumeration value to an integer type, such as 7553 -- occurs for the case of generating a range check on Enum'Val(Exp) 7554 -- (which used to be handled by gigi). This is OK, since the conversion 7555 -- itself does not require a check. 7556 7557 elsif In_Subrange_Of (Target_Type, Source_Base_Type) then 7558 7559 -- Insert the explicit range check. Note that we suppress checks for 7560 -- this code, since we don't want a recursive range check popping up. 7561 7562 if Is_Discrete_Type (Source_Base_Type) 7563 and then 7564 Is_Discrete_Type (Target_Base_Type) 7565 then 7566 Insert_Action (N, 7567 Make_Raise_Constraint_Error (Loc, 7568 Condition => 7569 Make_Not_In (Loc, 7570 Left_Opnd => Duplicate_Subexpr (N), 7571 7572 Right_Opnd => 7573 Make_Range (Loc, 7574 Low_Bound => 7575 Unchecked_Convert_To (Source_Base_Type, 7576 Make_Attribute_Reference (Loc, 7577 Prefix => 7578 New_Occurrence_Of (Target_Type, Loc), 7579 Attribute_Name => Name_First)), 7580 7581 High_Bound => 7582 Unchecked_Convert_To (Source_Base_Type, 7583 Make_Attribute_Reference (Loc, 7584 Prefix => 7585 New_Occurrence_Of (Target_Type, Loc), 7586 Attribute_Name => Name_Last)))), 7587 Reason => Reason), 7588 Suppress => All_Checks); 7589 7590 -- For conversions involving at least one type that is not discrete, 7591 -- first convert to the target base type and then generate the range 7592 -- check. This avoids problems with values that are close to a bound 7593 -- of the target type that would fail a range check when done in a 7594 -- larger source type before converting but pass if converted with 7595 -- rounding and then checked (such as in float-to-float conversions). 7596 7597 -- Note that overflow checks are not suppressed for this code because 7598 -- we do not know whether the source type is in range of the target 7599 -- base type (unlike in the next case below). 7600 7601 else 7602 Convert_And_Check_Range (Suppress => Range_Check); 7603 end if; 7604 7605 -- Note that at this stage we know that the Target_Base_Type is not in 7606 -- the range of the Source_Base_Type (since even the Target_Type itself 7607 -- is not in this range). It could still be the case that Source_Type is 7608 -- in range of the target base type since we have not checked that case. 7609 7610 -- If that is the case, we can freely convert the source to the target, 7611 -- and then test the target result against the bounds. Note that checks 7612 -- are suppressed for this code, since we don't want a recursive range 7613 -- check popping up. 7614 7615 elsif In_Subrange_Of (Source_Type, Target_Base_Type) then 7616 Convert_And_Check_Range (Suppress => All_Checks); 7617 7618 -- At this stage, we know that we have two scalar types, which are 7619 -- directly convertible, and where neither scalar type has a base 7620 -- range that is in the range of the other scalar type. 7621 7622 -- The only way this can happen is with a signed and unsigned type. 7623 -- So test for these two cases: 7624 7625 else 7626 -- Case of the source is unsigned and the target is signed 7627 7628 if Is_Unsigned_Type (Source_Base_Type) 7629 and then not Is_Unsigned_Type (Target_Base_Type) 7630 then 7631 -- If the source is unsigned and the target is signed, then we 7632 -- know that the source is not shorter than the target (otherwise 7633 -- the source base type would be in the target base type range). 7634 7635 -- In other words, the unsigned type is either the same size as 7636 -- the target, or it is larger. It cannot be smaller. 7637 7638 pragma Assert 7639 (Esize (Source_Base_Type) >= Esize (Target_Base_Type)); 7640 7641 -- We only need to check the low bound if the low bound of the 7642 -- target type is non-negative. If the low bound of the target 7643 -- type is negative, then we know that we will fit fine. 7644 7645 -- If the high bound of the target type is negative, then we 7646 -- know we have a constraint error, since we can't possibly 7647 -- have a negative source. 7648 7649 -- With these two checks out of the way, we can do the check 7650 -- using the source type safely 7651 7652 -- This is definitely the most annoying case. 7653 7654 -- [constraint_error 7655 -- when (Target_Type'First >= 0 7656 -- and then 7657 -- N < Source_Base_Type (Target_Type'First)) 7658 -- or else Target_Type'Last < 0 7659 -- or else N > Source_Base_Type (Target_Type'Last)]; 7660 7661 -- We turn off all checks since we know that the conversions 7662 -- will work fine, given the guards for negative values. 7663 7664 Insert_Action (N, 7665 Make_Raise_Constraint_Error (Loc, 7666 Condition => 7667 Make_Or_Else (Loc, 7668 Make_Or_Else (Loc, 7669 Left_Opnd => 7670 Make_And_Then (Loc, 7671 Left_Opnd => Make_Op_Ge (Loc, 7672 Left_Opnd => 7673 Make_Attribute_Reference (Loc, 7674 Prefix => 7675 New_Occurrence_Of (Target_Type, Loc), 7676 Attribute_Name => Name_First), 7677 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), 7678 7679 Right_Opnd => 7680 Make_Op_Lt (Loc, 7681 Left_Opnd => Duplicate_Subexpr (N), 7682 Right_Opnd => 7683 Convert_To (Source_Base_Type, 7684 Make_Attribute_Reference (Loc, 7685 Prefix => 7686 New_Occurrence_Of (Target_Type, Loc), 7687 Attribute_Name => Name_First)))), 7688 7689 Right_Opnd => 7690 Make_Op_Lt (Loc, 7691 Left_Opnd => 7692 Make_Attribute_Reference (Loc, 7693 Prefix => New_Occurrence_Of (Target_Type, Loc), 7694 Attribute_Name => Name_Last), 7695 Right_Opnd => Make_Integer_Literal (Loc, Uint_0))), 7696 7697 Right_Opnd => 7698 Make_Op_Gt (Loc, 7699 Left_Opnd => Duplicate_Subexpr (N), 7700 Right_Opnd => 7701 Convert_To (Source_Base_Type, 7702 Make_Attribute_Reference (Loc, 7703 Prefix => New_Occurrence_Of (Target_Type, Loc), 7704 Attribute_Name => Name_Last)))), 7705 7706 Reason => Reason), 7707 Suppress => All_Checks); 7708 7709 -- Only remaining possibility is that the source is signed and 7710 -- the target is unsigned. 7711 7712 else 7713 pragma Assert (not Is_Unsigned_Type (Source_Base_Type) 7714 and then Is_Unsigned_Type (Target_Base_Type)); 7715 7716 -- If the source is signed and the target is unsigned, then we 7717 -- know that the target is not shorter than the source (otherwise 7718 -- the target base type would be in the source base type range). 7719 7720 -- In other words, the unsigned type is either the same size as 7721 -- the target, or it is larger. It cannot be smaller. 7722 7723 -- Clearly we have an error if the source value is negative since 7724 -- no unsigned type can have negative values. If the source type 7725 -- is non-negative, then the check can be done using the target 7726 -- type. 7727 7728 -- Tnn : constant Target_Base_Type (N) := Target_Type; 7729 7730 -- [constraint_error 7731 -- when N < 0 or else Tnn not in Target_Type]; 7732 7733 -- We turn off all checks for the conversion of N to the target 7734 -- base type, since we generate the explicit check to ensure that 7735 -- the value is non-negative 7736 7737 declare 7738 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N); 7739 7740 begin 7741 Insert_Actions (N, New_List ( 7742 Make_Object_Declaration (Loc, 7743 Defining_Identifier => Tnn, 7744 Object_Definition => 7745 New_Occurrence_Of (Target_Base_Type, Loc), 7746 Constant_Present => True, 7747 Expression => 7748 Make_Unchecked_Type_Conversion (Loc, 7749 Subtype_Mark => 7750 New_Occurrence_Of (Target_Base_Type, Loc), 7751 Expression => Duplicate_Subexpr (N))), 7752 7753 Make_Raise_Constraint_Error (Loc, 7754 Condition => 7755 Make_Or_Else (Loc, 7756 Left_Opnd => 7757 Make_Op_Lt (Loc, 7758 Left_Opnd => Duplicate_Subexpr (N), 7759 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), 7760 7761 Right_Opnd => 7762 Make_Not_In (Loc, 7763 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 7764 Right_Opnd => 7765 New_Occurrence_Of (Target_Type, Loc))), 7766 7767 Reason => Reason)), 7768 Suppress => All_Checks); 7769 7770 -- Set the Etype explicitly, because Insert_Actions may have 7771 -- placed the declaration in the freeze list for an enclosing 7772 -- construct, and thus it is not analyzed yet. 7773 7774 Set_Etype (Tnn, Target_Base_Type); 7775 Rewrite (N, New_Occurrence_Of (Tnn, Loc)); 7776 end; 7777 end if; 7778 end if; 7779 end Generate_Range_Check; 7780 7781 ------------------ 7782 -- Get_Check_Id -- 7783 ------------------ 7784 7785 function Get_Check_Id (N : Name_Id) return Check_Id is 7786 begin 7787 -- For standard check name, we can do a direct computation 7788 7789 if N in First_Check_Name .. Last_Check_Name then 7790 return Check_Id (N - (First_Check_Name - 1)); 7791 7792 -- For non-standard names added by pragma Check_Name, search table 7793 7794 else 7795 for J in All_Checks + 1 .. Check_Names.Last loop 7796 if Check_Names.Table (J) = N then 7797 return J; 7798 end if; 7799 end loop; 7800 end if; 7801 7802 -- No matching name found 7803 7804 return No_Check_Id; 7805 end Get_Check_Id; 7806 7807 --------------------- 7808 -- Get_Discriminal -- 7809 --------------------- 7810 7811 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is 7812 Loc : constant Source_Ptr := Sloc (E); 7813 D : Entity_Id; 7814 Sc : Entity_Id; 7815 7816 begin 7817 -- The bound can be a bona fide parameter of a protected operation, 7818 -- rather than a prival encoded as an in-parameter. 7819 7820 if No (Discriminal_Link (Entity (Bound))) then 7821 return Bound; 7822 end if; 7823 7824 -- Climb the scope stack looking for an enclosing protected type. If 7825 -- we run out of scopes, return the bound itself. 7826 7827 Sc := Scope (E); 7828 while Present (Sc) loop 7829 if Sc = Standard_Standard then 7830 return Bound; 7831 elsif Ekind (Sc) = E_Protected_Type then 7832 exit; 7833 end if; 7834 7835 Sc := Scope (Sc); 7836 end loop; 7837 7838 D := First_Discriminant (Sc); 7839 while Present (D) loop 7840 if Chars (D) = Chars (Bound) then 7841 return New_Occurrence_Of (Discriminal (D), Loc); 7842 end if; 7843 7844 Next_Discriminant (D); 7845 end loop; 7846 7847 return Bound; 7848 end Get_Discriminal; 7849 7850 ---------------------- 7851 -- Get_Range_Checks -- 7852 ---------------------- 7853 7854 function Get_Range_Checks 7855 (Expr : Node_Id; 7856 Target_Typ : Entity_Id; 7857 Source_Typ : Entity_Id := Empty; 7858 Warn_Node : Node_Id := Empty) return Check_Result 7859 is 7860 begin 7861 return 7862 Selected_Range_Checks (Expr, Target_Typ, Source_Typ, Warn_Node); 7863 end Get_Range_Checks; 7864 7865 ------------------ 7866 -- Guard_Access -- 7867 ------------------ 7868 7869 function Guard_Access 7870 (Cond : Node_Id; 7871 Loc : Source_Ptr; 7872 Expr : Node_Id) return Node_Id 7873 is 7874 begin 7875 if Nkind (Cond) = N_Or_Else then 7876 Set_Paren_Count (Cond, 1); 7877 end if; 7878 7879 if Nkind (Expr) = N_Allocator then 7880 return Cond; 7881 7882 else 7883 return 7884 Make_And_Then (Loc, 7885 Left_Opnd => 7886 Make_Op_Ne (Loc, 7887 Left_Opnd => Duplicate_Subexpr_No_Checks (Expr), 7888 Right_Opnd => Make_Null (Loc)), 7889 Right_Opnd => Cond); 7890 end if; 7891 end Guard_Access; 7892 7893 ----------------------------- 7894 -- Index_Checks_Suppressed -- 7895 ----------------------------- 7896 7897 function Index_Checks_Suppressed (E : Entity_Id) return Boolean is 7898 begin 7899 if Present (E) and then Checks_May_Be_Suppressed (E) then 7900 return Is_Check_Suppressed (E, Index_Check); 7901 else 7902 return Scope_Suppress.Suppress (Index_Check); 7903 end if; 7904 end Index_Checks_Suppressed; 7905 7906 ---------------- 7907 -- Initialize -- 7908 ---------------- 7909 7910 procedure Initialize is 7911 begin 7912 for J in Determine_Range_Cache_N'Range loop 7913 Determine_Range_Cache_N (J) := Empty; 7914 end loop; 7915 7916 Check_Names.Init; 7917 7918 for J in Int range 1 .. All_Checks loop 7919 Check_Names.Append (Name_Id (Int (First_Check_Name) + J - 1)); 7920 end loop; 7921 end Initialize; 7922 7923 ------------------------- 7924 -- Insert_Range_Checks -- 7925 ------------------------- 7926 7927 procedure Insert_Range_Checks 7928 (Checks : Check_Result; 7929 Node : Node_Id; 7930 Suppress_Typ : Entity_Id; 7931 Static_Sloc : Source_Ptr; 7932 Do_Before : Boolean := False) 7933 is 7934 Checks_On : constant Boolean := 7935 not Index_Checks_Suppressed (Suppress_Typ) 7936 or else 7937 not Range_Checks_Suppressed (Suppress_Typ); 7938 7939 Check_Node : Node_Id; 7940 7941 begin 7942 -- For now we just return if Checks_On is false, however this should be 7943 -- enhanced to check for an always True value in the condition and to 7944 -- generate a compilation warning??? 7945 7946 if not Expander_Active or not Checks_On then 7947 return; 7948 end if; 7949 7950 for J in 1 .. 2 loop 7951 exit when No (Checks (J)); 7952 7953 if Nkind (Checks (J)) = N_Raise_Constraint_Error 7954 and then Present (Condition (Checks (J))) 7955 then 7956 Check_Node := Checks (J); 7957 else 7958 Check_Node := 7959 Make_Raise_Constraint_Error (Static_Sloc, 7960 Reason => CE_Range_Check_Failed); 7961 end if; 7962 7963 Mark_Rewrite_Insertion (Check_Node); 7964 7965 if Do_Before then 7966 Insert_Before_And_Analyze (Node, Check_Node); 7967 else 7968 Insert_After_And_Analyze (Node, Check_Node); 7969 end if; 7970 end loop; 7971 end Insert_Range_Checks; 7972 7973 ------------------------ 7974 -- Insert_Valid_Check -- 7975 ------------------------ 7976 7977 procedure Insert_Valid_Check 7978 (Expr : Node_Id; 7979 Related_Id : Entity_Id := Empty; 7980 Is_Low_Bound : Boolean := False; 7981 Is_High_Bound : Boolean := False) 7982 is 7983 Loc : constant Source_Ptr := Sloc (Expr); 7984 Typ : constant Entity_Id := Etype (Expr); 7985 Exp : Node_Id; 7986 7987 begin 7988 -- Do not insert if checks off, or if not checking validity or if 7989 -- expression is known to be valid. 7990 7991 if not Validity_Checks_On 7992 or else Range_Or_Validity_Checks_Suppressed (Expr) 7993 or else Expr_Known_Valid (Expr) 7994 then 7995 return; 7996 7997 -- Do not insert checks within a predicate function. This will arise 7998 -- if the current unit and the predicate function are being compiled 7999 -- with validity checks enabled. 8000 8001 elsif Present (Predicate_Function (Typ)) 8002 and then Current_Scope = Predicate_Function (Typ) 8003 then 8004 return; 8005 8006 -- If the expression is a packed component of a modular type of the 8007 -- right size, the data is always valid. 8008 8009 elsif Nkind (Expr) = N_Selected_Component 8010 and then Present (Component_Clause (Entity (Selector_Name (Expr)))) 8011 and then Is_Modular_Integer_Type (Typ) 8012 and then Modulus (Typ) = 2 ** Esize (Entity (Selector_Name (Expr))) 8013 then 8014 return; 8015 8016 -- Do not generate a validity check when inside a generic unit as this 8017 -- is an expansion activity. 8018 8019 elsif Inside_A_Generic then 8020 return; 8021 end if; 8022 8023 -- Entities declared in Lock_free protected types must be treated as 8024 -- volatile, and we must inhibit validity checks to prevent improper 8025 -- constant folding. 8026 8027 if Is_Entity_Name (Expr) 8028 and then Is_Subprogram (Scope (Entity (Expr))) 8029 and then Present (Protected_Subprogram (Scope (Entity (Expr)))) 8030 and then Uses_Lock_Free 8031 (Scope (Protected_Subprogram (Scope (Entity (Expr))))) 8032 then 8033 return; 8034 end if; 8035 8036 -- If we have a checked conversion, then validity check applies to 8037 -- the expression inside the conversion, not the result, since if 8038 -- the expression inside is valid, then so is the conversion result. 8039 8040 Exp := Expr; 8041 while Nkind (Exp) = N_Type_Conversion loop 8042 Exp := Expression (Exp); 8043 end loop; 8044 8045 -- Do not generate a check for a variable which already validates the 8046 -- value of an assignable object. 8047 8048 if Is_Validation_Variable_Reference (Exp) then 8049 return; 8050 end if; 8051 8052 declare 8053 CE : Node_Id; 8054 PV : Node_Id; 8055 Var_Id : Entity_Id; 8056 8057 begin 8058 -- If the expression denotes an assignable object, capture its value 8059 -- in a variable and replace the original expression by the variable. 8060 -- This approach has several effects: 8061 8062 -- 1) The evaluation of the object results in only one read in the 8063 -- case where the object is atomic or volatile. 8064 8065 -- Var ... := Object; -- read 8066 8067 -- 2) The captured value is the one verified by attribute 'Valid. 8068 -- As a result the object is not evaluated again, which would 8069 -- result in an unwanted read in the case where the object is 8070 -- atomic or volatile. 8071 8072 -- if not Var'Valid then -- OK, no read of Object 8073 8074 -- if not Object'Valid then -- Wrong, extra read of Object 8075 8076 -- 3) The captured value replaces the original object reference. 8077 -- As a result the object is not evaluated again, in the same 8078 -- vein as 2). 8079 8080 -- ... Var ... -- OK, no read of Object 8081 8082 -- ... Object ... -- Wrong, extra read of Object 8083 8084 -- 4) The use of a variable to capture the value of the object 8085 -- allows the propagation of any changes back to the original 8086 -- object. 8087 8088 -- procedure Call (Val : in out ...); 8089 8090 -- Var : ... := Object; -- read Object 8091 -- if not Var'Valid then -- validity check 8092 -- Call (Var); -- modify Var 8093 -- Object := Var; -- update Object 8094 8095 if Is_Variable (Exp) then 8096 Var_Id := Make_Temporary (Loc, 'T', Exp); 8097 8098 -- Because we could be dealing with a transient scope which would 8099 -- cause our object declaration to remain unanalyzed we must do 8100 -- some manual decoration. 8101 8102 Set_Ekind (Var_Id, E_Variable); 8103 Set_Etype (Var_Id, Typ); 8104 8105 Insert_Action (Exp, 8106 Make_Object_Declaration (Loc, 8107 Defining_Identifier => Var_Id, 8108 Object_Definition => New_Occurrence_Of (Typ, Loc), 8109 Expression => New_Copy_Tree (Exp)), 8110 Suppress => Validity_Check); 8111 8112 Set_Validated_Object (Var_Id, New_Copy_Tree (Exp)); 8113 8114 Rewrite (Exp, New_Occurrence_Of (Var_Id, Loc)); 8115 8116 -- Move the Do_Range_Check flag over to the new Exp so it doesn't 8117 -- get lost and doesn't leak elsewhere. 8118 8119 if Do_Range_Check (Validated_Object (Var_Id)) then 8120 Set_Do_Range_Check (Exp); 8121 Set_Do_Range_Check (Validated_Object (Var_Id), False); 8122 end if; 8123 8124 PV := New_Occurrence_Of (Var_Id, Loc); 8125 8126 -- Otherwise the expression does not denote a variable. Force its 8127 -- evaluation by capturing its value in a constant. Generate: 8128 8129 -- Temp : constant ... := Exp; 8130 8131 else 8132 Force_Evaluation 8133 (Exp => Exp, 8134 Related_Id => Related_Id, 8135 Is_Low_Bound => Is_Low_Bound, 8136 Is_High_Bound => Is_High_Bound); 8137 8138 PV := New_Copy_Tree (Exp); 8139 end if; 8140 8141 -- A rather specialized test. If PV is an analyzed expression which 8142 -- is an indexed component of a packed array that has not been 8143 -- properly expanded, turn off its Analyzed flag to make sure it 8144 -- gets properly reexpanded. If the prefix is an access value, 8145 -- the dereference will be added later. 8146 8147 -- The reason this arises is that Duplicate_Subexpr_No_Checks did 8148 -- an analyze with the old parent pointer. This may point e.g. to 8149 -- a subprogram call, which deactivates this expansion. 8150 8151 if Analyzed (PV) 8152 and then Nkind (PV) = N_Indexed_Component 8153 and then Is_Array_Type (Etype (Prefix (PV))) 8154 and then Present (Packed_Array_Impl_Type (Etype (Prefix (PV)))) 8155 then 8156 Set_Analyzed (PV, False); 8157 end if; 8158 8159 -- Build the raise CE node to check for validity. We build a type 8160 -- qualification for the prefix, since it may not be of the form of 8161 -- a name, and we don't care in this context! 8162 8163 CE := 8164 Make_Raise_Constraint_Error (Loc, 8165 Condition => 8166 Make_Op_Not (Loc, 8167 Right_Opnd => 8168 Make_Attribute_Reference (Loc, 8169 Prefix => PV, 8170 Attribute_Name => Name_Valid)), 8171 Reason => CE_Invalid_Data); 8172 8173 -- Insert the validity check. Note that we do this with validity 8174 -- checks turned off, to avoid recursion, we do not want validity 8175 -- checks on the validity checking code itself. 8176 8177 Insert_Action (Expr, CE, Suppress => Validity_Check); 8178 8179 -- If the expression is a reference to an element of a bit-packed 8180 -- array, then it is rewritten as a renaming declaration. If the 8181 -- expression is an actual in a call, it has not been expanded, 8182 -- waiting for the proper point at which to do it. The same happens 8183 -- with renamings, so that we have to force the expansion now. This 8184 -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb 8185 -- and exp_ch6.adb. 8186 8187 if Is_Entity_Name (Exp) 8188 and then Nkind (Parent (Entity (Exp))) = 8189 N_Object_Renaming_Declaration 8190 then 8191 declare 8192 Old_Exp : constant Node_Id := Name (Parent (Entity (Exp))); 8193 begin 8194 if Nkind (Old_Exp) = N_Indexed_Component 8195 and then Is_Bit_Packed_Array (Etype (Prefix (Old_Exp))) 8196 then 8197 Expand_Packed_Element_Reference (Old_Exp); 8198 end if; 8199 end; 8200 end if; 8201 end; 8202 end Insert_Valid_Check; 8203 8204 ------------------------------------- 8205 -- Is_Signed_Integer_Arithmetic_Op -- 8206 ------------------------------------- 8207 8208 function Is_Signed_Integer_Arithmetic_Op (N : Node_Id) return Boolean is 8209 begin 8210 case Nkind (N) is 8211 when N_Op_Abs 8212 | N_Op_Add 8213 | N_Op_Divide 8214 | N_Op_Expon 8215 | N_Op_Minus 8216 | N_Op_Mod 8217 | N_Op_Multiply 8218 | N_Op_Plus 8219 | N_Op_Rem 8220 | N_Op_Subtract 8221 => 8222 return Is_Signed_Integer_Type (Etype (N)); 8223 8224 when N_Case_Expression 8225 | N_If_Expression 8226 => 8227 return Is_Signed_Integer_Type (Etype (N)); 8228 8229 when others => 8230 return False; 8231 end case; 8232 end Is_Signed_Integer_Arithmetic_Op; 8233 8234 ---------------------------------- 8235 -- Install_Null_Excluding_Check -- 8236 ---------------------------------- 8237 8238 procedure Install_Null_Excluding_Check (N : Node_Id) is 8239 Loc : constant Source_Ptr := Sloc (Parent (N)); 8240 Typ : constant Entity_Id := Etype (N); 8241 8242 function Safe_To_Capture_In_Parameter_Value return Boolean; 8243 -- Determines if it is safe to capture Known_Non_Null status for an 8244 -- the entity referenced by node N. The caller ensures that N is indeed 8245 -- an entity name. It is safe to capture the non-null status for an IN 8246 -- parameter when the reference occurs within a declaration that is sure 8247 -- to be executed as part of the declarative region. 8248 8249 procedure Mark_Non_Null; 8250 -- After installation of check, if the node in question is an entity 8251 -- name, then mark this entity as non-null if possible. 8252 8253 function Safe_To_Capture_In_Parameter_Value return Boolean is 8254 E : constant Entity_Id := Entity (N); 8255 S : constant Entity_Id := Current_Scope; 8256 S_Par : Node_Id; 8257 8258 begin 8259 if Ekind (E) /= E_In_Parameter then 8260 return False; 8261 end if; 8262 8263 -- Two initial context checks. We must be inside a subprogram body 8264 -- with declarations and reference must not appear in nested scopes. 8265 8266 if (Ekind (S) /= E_Function and then Ekind (S) /= E_Procedure) 8267 or else Scope (E) /= S 8268 then 8269 return False; 8270 end if; 8271 8272 S_Par := Parent (Parent (S)); 8273 8274 if Nkind (S_Par) /= N_Subprogram_Body 8275 or else No (Declarations (S_Par)) 8276 then 8277 return False; 8278 end if; 8279 8280 declare 8281 N_Decl : Node_Id; 8282 P : Node_Id; 8283 8284 begin 8285 -- Retrieve the declaration node of N (if any). Note that N 8286 -- may be a part of a complex initialization expression. 8287 8288 P := Parent (N); 8289 N_Decl := Empty; 8290 while Present (P) loop 8291 8292 -- If we have a short circuit form, and we are within the right 8293 -- hand expression, we return false, since the right hand side 8294 -- is not guaranteed to be elaborated. 8295 8296 if Nkind (P) in N_Short_Circuit 8297 and then N = Right_Opnd (P) 8298 then 8299 return False; 8300 end if; 8301 8302 -- Similarly, if we are in an if expression and not part of the 8303 -- condition, then we return False, since neither the THEN or 8304 -- ELSE dependent expressions will always be elaborated. 8305 8306 if Nkind (P) = N_If_Expression 8307 and then N /= First (Expressions (P)) 8308 then 8309 return False; 8310 end if; 8311 8312 -- If within a case expression, and not part of the expression, 8313 -- then return False, since a particular dependent expression 8314 -- may not always be elaborated 8315 8316 if Nkind (P) = N_Case_Expression 8317 and then N /= Expression (P) 8318 then 8319 return False; 8320 end if; 8321 8322 -- While traversing the parent chain, if node N belongs to a 8323 -- statement, then it may never appear in a declarative region. 8324 8325 if Nkind (P) in N_Statement_Other_Than_Procedure_Call 8326 or else Nkind (P) = N_Procedure_Call_Statement 8327 then 8328 return False; 8329 end if; 8330 8331 -- If we are at a declaration, record it and exit 8332 8333 if Nkind (P) in N_Declaration 8334 and then Nkind (P) not in N_Subprogram_Specification 8335 then 8336 N_Decl := P; 8337 exit; 8338 end if; 8339 8340 P := Parent (P); 8341 end loop; 8342 8343 if No (N_Decl) then 8344 return False; 8345 end if; 8346 8347 return List_Containing (N_Decl) = Declarations (S_Par); 8348 end; 8349 end Safe_To_Capture_In_Parameter_Value; 8350 8351 ------------------- 8352 -- Mark_Non_Null -- 8353 ------------------- 8354 8355 procedure Mark_Non_Null is 8356 begin 8357 -- Only case of interest is if node N is an entity name 8358 8359 if Is_Entity_Name (N) then 8360 8361 -- For sure, we want to clear an indication that this is known to 8362 -- be null, since if we get past this check, it definitely is not. 8363 8364 Set_Is_Known_Null (Entity (N), False); 8365 8366 -- We can mark the entity as known to be non-null if either it is 8367 -- safe to capture the value, or in the case of an IN parameter, 8368 -- which is a constant, if the check we just installed is in the 8369 -- declarative region of the subprogram body. In this latter case, 8370 -- a check is decisive for the rest of the body if the expression 8371 -- is sure to be elaborated, since we know we have to elaborate 8372 -- all declarations before executing the body. 8373 8374 -- Couldn't this always be part of Safe_To_Capture_Value ??? 8375 8376 if Safe_To_Capture_Value (N, Entity (N)) 8377 or else Safe_To_Capture_In_Parameter_Value 8378 then 8379 Set_Is_Known_Non_Null (Entity (N)); 8380 end if; 8381 end if; 8382 end Mark_Non_Null; 8383 8384 -- Start of processing for Install_Null_Excluding_Check 8385 8386 begin 8387 -- No need to add null-excluding checks when the tree may not be fully 8388 -- decorated. 8389 8390 if Serious_Errors_Detected > 0 then 8391 return; 8392 end if; 8393 8394 pragma Assert (Is_Access_Type (Typ)); 8395 8396 -- No check inside a generic, check will be emitted in instance 8397 8398 if Inside_A_Generic then 8399 return; 8400 end if; 8401 8402 -- No check needed if known to be non-null 8403 8404 if Known_Non_Null (N) then 8405 return; 8406 end if; 8407 8408 -- If known to be null, here is where we generate a compile time check 8409 8410 if Known_Null (N) then 8411 8412 -- Avoid generating warning message inside init procs. In SPARK mode 8413 -- we can go ahead and call Apply_Compile_Time_Constraint_Error 8414 -- since it will be turned into an error in any case. 8415 8416 if (not Inside_Init_Proc or else SPARK_Mode = On) 8417 8418 -- Do not emit the warning within a conditional expression, 8419 -- where the expression might not be evaluated, and the warning 8420 -- appear as extraneous noise. 8421 8422 and then not Within_Case_Or_If_Expression (N) 8423 then 8424 Apply_Compile_Time_Constraint_Error 8425 (N, "null value not allowed here??", CE_Access_Check_Failed); 8426 8427 -- Remaining cases, where we silently insert the raise 8428 8429 else 8430 Insert_Action (N, 8431 Make_Raise_Constraint_Error (Loc, 8432 Reason => CE_Access_Check_Failed)); 8433 end if; 8434 8435 Mark_Non_Null; 8436 return; 8437 end if; 8438 8439 -- If entity is never assigned, for sure a warning is appropriate 8440 8441 if Is_Entity_Name (N) then 8442 Check_Unset_Reference (N); 8443 end if; 8444 8445 -- No check needed if checks are suppressed on the range. Note that we 8446 -- don't set Is_Known_Non_Null in this case (we could legitimately do 8447 -- so, since the program is erroneous, but we don't like to casually 8448 -- propagate such conclusions from erroneosity). 8449 8450 if Access_Checks_Suppressed (Typ) then 8451 return; 8452 end if; 8453 8454 -- No check needed for access to concurrent record types generated by 8455 -- the expander. This is not just an optimization (though it does indeed 8456 -- remove junk checks). It also avoids generation of junk warnings. 8457 8458 if Nkind (N) in N_Has_Chars 8459 and then Chars (N) = Name_uObject 8460 and then Is_Concurrent_Record_Type 8461 (Directly_Designated_Type (Etype (N))) 8462 then 8463 return; 8464 end if; 8465 8466 -- No check needed in interface thunks since the runtime check is 8467 -- already performed at the caller side. 8468 8469 if Is_Thunk (Current_Scope) then 8470 return; 8471 end if; 8472 8473 -- No check needed for the Get_Current_Excep.all.all idiom generated by 8474 -- the expander within exception handlers, since we know that the value 8475 -- can never be null. 8476 8477 -- Is this really the right way to do this? Normally we generate such 8478 -- code in the expander with checks off, and that's how we suppress this 8479 -- kind of junk check ??? 8480 8481 if Nkind (N) = N_Function_Call 8482 and then Nkind (Name (N)) = N_Explicit_Dereference 8483 and then Nkind (Prefix (Name (N))) = N_Identifier 8484 and then Is_RTE (Entity (Prefix (Name (N))), RE_Get_Current_Excep) 8485 then 8486 return; 8487 end if; 8488 8489 -- In GNATprove mode, we do not apply the check 8490 8491 if GNATprove_Mode then 8492 return; 8493 end if; 8494 8495 -- Otherwise install access check 8496 8497 Insert_Action (N, 8498 Make_Raise_Constraint_Error (Loc, 8499 Condition => 8500 Make_Op_Eq (Loc, 8501 Left_Opnd => Duplicate_Subexpr_Move_Checks (N), 8502 Right_Opnd => Make_Null (Loc)), 8503 Reason => CE_Access_Check_Failed)); 8504 8505 Mark_Non_Null; 8506 end Install_Null_Excluding_Check; 8507 8508 ----------------------------------------- 8509 -- Install_Primitive_Elaboration_Check -- 8510 ----------------------------------------- 8511 8512 procedure Install_Primitive_Elaboration_Check (Subp_Body : Node_Id) is 8513 function Within_Compilation_Unit_Instance 8514 (Subp_Id : Entity_Id) return Boolean; 8515 -- Determine whether subprogram Subp_Id appears within an instance which 8516 -- acts as a compilation unit. 8517 8518 -------------------------------------- 8519 -- Within_Compilation_Unit_Instance -- 8520 -------------------------------------- 8521 8522 function Within_Compilation_Unit_Instance 8523 (Subp_Id : Entity_Id) return Boolean 8524 is 8525 Pack : Entity_Id; 8526 8527 begin 8528 -- Examine the scope chain looking for a compilation-unit-level 8529 -- instance. 8530 8531 Pack := Scope (Subp_Id); 8532 while Present (Pack) and then Pack /= Standard_Standard loop 8533 if Ekind (Pack) = E_Package 8534 and then Is_Generic_Instance (Pack) 8535 and then Nkind (Parent (Unit_Declaration_Node (Pack))) = 8536 N_Compilation_Unit 8537 then 8538 return True; 8539 end if; 8540 8541 Pack := Scope (Pack); 8542 end loop; 8543 8544 return False; 8545 end Within_Compilation_Unit_Instance; 8546 8547 -- Local declarations 8548 8549 Context : constant Node_Id := Parent (Subp_Body); 8550 Loc : constant Source_Ptr := Sloc (Subp_Body); 8551 Subp_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Body); 8552 Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); 8553 8554 Decls : List_Id; 8555 Flag_Id : Entity_Id; 8556 Set_Ins : Node_Id; 8557 Set_Stmt : Node_Id; 8558 Tag_Typ : Entity_Id; 8559 8560 -- Start of processing for Install_Primitive_Elaboration_Check 8561 8562 begin 8563 -- Do not generate an elaboration check in compilation modes where 8564 -- expansion is not desirable. 8565 8566 if GNATprove_Mode then 8567 return; 8568 8569 -- Do not generate an elaboration check if all checks have been 8570 -- suppressed. 8571 8572 elsif Suppress_Checks then 8573 return; 8574 8575 -- Do not generate an elaboration check if the related subprogram is 8576 -- not subjected to accessibility checks. 8577 8578 elsif Elaboration_Checks_Suppressed (Subp_Id) then 8579 return; 8580 8581 -- Do not generate an elaboration check if such code is not desirable 8582 8583 elsif Restriction_Active (No_Elaboration_Code) then 8584 return; 8585 8586 -- Do not generate an elaboration check if exceptions cannot be used, 8587 -- caught, or propagated. 8588 8589 elsif not Exceptions_OK then 8590 return; 8591 8592 -- Do not consider subprograms which act as compilation units, because 8593 -- they cannot be the target of a dispatching call. 8594 8595 elsif Nkind (Context) = N_Compilation_Unit then 8596 return; 8597 8598 -- Do not consider anything other than nonabstract library-level source 8599 -- primitives. 8600 8601 elsif not 8602 (Comes_From_Source (Subp_Id) 8603 and then Is_Library_Level_Entity (Subp_Id) 8604 and then Is_Primitive (Subp_Id) 8605 and then not Is_Abstract_Subprogram (Subp_Id)) 8606 then 8607 return; 8608 8609 -- Do not consider inlined primitives, because once the body is inlined 8610 -- the reference to the elaboration flag will be out of place and will 8611 -- result in an undefined symbol. 8612 8613 elsif Is_Inlined (Subp_Id) or else Has_Pragma_Inline (Subp_Id) then 8614 return; 8615 8616 -- Do not generate a duplicate elaboration check. This happens only in 8617 -- the case of primitives completed by an expression function, as the 8618 -- corresponding body is apparently analyzed and expanded twice. 8619 8620 elsif Analyzed (Subp_Body) then 8621 return; 8622 8623 -- Do not consider primitives which occur within an instance that acts 8624 -- as a compilation unit. Such an instance defines its spec and body out 8625 -- of order (body is first) within the tree, which causes the reference 8626 -- to the elaboration flag to appear as an undefined symbol. 8627 8628 elsif Within_Compilation_Unit_Instance (Subp_Id) then 8629 return; 8630 end if; 8631 8632 Tag_Typ := Find_Dispatching_Type (Subp_Id); 8633 8634 -- Only tagged primitives may be the target of a dispatching call 8635 8636 if No (Tag_Typ) then 8637 return; 8638 8639 -- Do not consider finalization-related primitives, because they may 8640 -- need to be called while elaboration is taking place. 8641 8642 elsif Is_Controlled (Tag_Typ) 8643 and then 8644 Chars (Subp_Id) in Name_Adjust | Name_Finalize | Name_Initialize 8645 then 8646 return; 8647 end if; 8648 8649 -- Create the declaration of the elaboration flag. The name carries a 8650 -- unique counter in case of name overloading. 8651 8652 Flag_Id := 8653 Make_Defining_Identifier (Loc, 8654 Chars => New_External_Name (Chars (Subp_Id), 'E', -1)); 8655 Set_Is_Frozen (Flag_Id); 8656 8657 -- Insert the declaration of the elaboration flag in front of the 8658 -- primitive spec and analyze it in the proper context. 8659 8660 Push_Scope (Scope (Subp_Id)); 8661 8662 -- Generate: 8663 -- E : Boolean := False; 8664 8665 Insert_Action (Subp_Decl, 8666 Make_Object_Declaration (Loc, 8667 Defining_Identifier => Flag_Id, 8668 Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc), 8669 Expression => New_Occurrence_Of (Standard_False, Loc))); 8670 Pop_Scope; 8671 8672 -- Prevent the compiler from optimizing the elaboration check by killing 8673 -- the current value of the flag and the associated assignment. 8674 8675 Set_Current_Value (Flag_Id, Empty); 8676 Set_Last_Assignment (Flag_Id, Empty); 8677 8678 -- Add a check at the top of the body declarations to ensure that the 8679 -- elaboration flag has been set. 8680 8681 Decls := Declarations (Subp_Body); 8682 8683 if No (Decls) then 8684 Decls := New_List; 8685 Set_Declarations (Subp_Body, Decls); 8686 end if; 8687 8688 -- Generate: 8689 -- if not F then 8690 -- raise Program_Error with "access before elaboration"; 8691 -- end if; 8692 8693 Prepend_To (Decls, 8694 Make_Raise_Program_Error (Loc, 8695 Condition => 8696 Make_Op_Not (Loc, 8697 Right_Opnd => New_Occurrence_Of (Flag_Id, Loc)), 8698 Reason => PE_Access_Before_Elaboration)); 8699 8700 Analyze (First (Decls)); 8701 8702 -- Set the elaboration flag once the body has been elaborated. Insert 8703 -- the statement after the subprogram stub when the primitive body is 8704 -- a subunit. 8705 8706 if Nkind (Context) = N_Subunit then 8707 Set_Ins := Corresponding_Stub (Context); 8708 else 8709 Set_Ins := Subp_Body; 8710 end if; 8711 8712 -- Generate: 8713 -- E := True; 8714 8715 Set_Stmt := 8716 Make_Assignment_Statement (Loc, 8717 Name => New_Occurrence_Of (Flag_Id, Loc), 8718 Expression => New_Occurrence_Of (Standard_True, Loc)); 8719 8720 -- Mark the assignment statement as elaboration code. This allows the 8721 -- early call region mechanism (see Sem_Elab) to properly ignore such 8722 -- assignments even though they are non-preelaborable code. 8723 8724 Set_Is_Elaboration_Code (Set_Stmt); 8725 8726 Insert_After_And_Analyze (Set_Ins, Set_Stmt); 8727 end Install_Primitive_Elaboration_Check; 8728 8729 -------------------------- 8730 -- Install_Static_Check -- 8731 -------------------------- 8732 8733 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is 8734 Stat : constant Boolean := Is_OK_Static_Expression (R_Cno); 8735 Typ : constant Entity_Id := Etype (R_Cno); 8736 8737 begin 8738 Rewrite (R_Cno, 8739 Make_Raise_Constraint_Error (Loc, 8740 Reason => CE_Range_Check_Failed)); 8741 Set_Analyzed (R_Cno); 8742 Set_Etype (R_Cno, Typ); 8743 Set_Raises_Constraint_Error (R_Cno); 8744 Set_Is_Static_Expression (R_Cno, Stat); 8745 8746 -- Now deal with possible local raise handling 8747 8748 Possible_Local_Raise (R_Cno, Standard_Constraint_Error); 8749 end Install_Static_Check; 8750 8751 ------------------------- 8752 -- Is_Check_Suppressed -- 8753 ------------------------- 8754 8755 function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is 8756 Ptr : Suppress_Stack_Entry_Ptr; 8757 8758 begin 8759 -- First search the local entity suppress stack. We search this from the 8760 -- top of the stack down so that we get the innermost entry that applies 8761 -- to this case if there are nested entries. 8762 8763 Ptr := Local_Suppress_Stack_Top; 8764 while Ptr /= null loop 8765 if (Ptr.Entity = Empty or else Ptr.Entity = E) 8766 and then (Ptr.Check = All_Checks or else Ptr.Check = C) 8767 then 8768 return Ptr.Suppress; 8769 end if; 8770 8771 Ptr := Ptr.Prev; 8772 end loop; 8773 8774 -- Now search the global entity suppress table for a matching entry. 8775 -- We also search this from the top down so that if there are multiple 8776 -- pragmas for the same entity, the last one applies (not clear what 8777 -- or whether the RM specifies this handling, but it seems reasonable). 8778 8779 Ptr := Global_Suppress_Stack_Top; 8780 while Ptr /= null loop 8781 if (Ptr.Entity = Empty or else Ptr.Entity = E) 8782 and then (Ptr.Check = All_Checks or else Ptr.Check = C) 8783 then 8784 return Ptr.Suppress; 8785 end if; 8786 8787 Ptr := Ptr.Prev; 8788 end loop; 8789 8790 -- If we did not find a matching entry, then use the normal scope 8791 -- suppress value after all (actually this will be the global setting 8792 -- since it clearly was not overridden at any point). For a predefined 8793 -- check, we test the specific flag. For a user defined check, we check 8794 -- the All_Checks flag. The Overflow flag requires special handling to 8795 -- deal with the General vs Assertion case. 8796 8797 if C = Overflow_Check then 8798 return Overflow_Checks_Suppressed (Empty); 8799 8800 elsif C in Predefined_Check_Id then 8801 return Scope_Suppress.Suppress (C); 8802 8803 else 8804 return Scope_Suppress.Suppress (All_Checks); 8805 end if; 8806 end Is_Check_Suppressed; 8807 8808 --------------------- 8809 -- Kill_All_Checks -- 8810 --------------------- 8811 8812 procedure Kill_All_Checks is 8813 begin 8814 if Debug_Flag_CC then 8815 w ("Kill_All_Checks"); 8816 end if; 8817 8818 -- We reset the number of saved checks to zero, and also modify all 8819 -- stack entries for statement ranges to indicate that the number of 8820 -- checks at each level is now zero. 8821 8822 Num_Saved_Checks := 0; 8823 8824 -- Note: the Int'Min here avoids any possibility of J being out of 8825 -- range when called from e.g. Conditional_Statements_Begin. 8826 8827 for J in 1 .. Int'Min (Saved_Checks_TOS, Saved_Checks_Stack'Last) loop 8828 Saved_Checks_Stack (J) := 0; 8829 end loop; 8830 end Kill_All_Checks; 8831 8832 ----------------- 8833 -- Kill_Checks -- 8834 ----------------- 8835 8836 procedure Kill_Checks (V : Entity_Id) is 8837 begin 8838 if Debug_Flag_CC then 8839 w ("Kill_Checks for entity", Int (V)); 8840 end if; 8841 8842 for J in 1 .. Num_Saved_Checks loop 8843 if Saved_Checks (J).Entity = V then 8844 if Debug_Flag_CC then 8845 w (" Checks killed for saved check ", J); 8846 end if; 8847 8848 Saved_Checks (J).Killed := True; 8849 end if; 8850 end loop; 8851 end Kill_Checks; 8852 8853 ------------------------------ 8854 -- Length_Checks_Suppressed -- 8855 ------------------------------ 8856 8857 function Length_Checks_Suppressed (E : Entity_Id) return Boolean is 8858 begin 8859 if Present (E) and then Checks_May_Be_Suppressed (E) then 8860 return Is_Check_Suppressed (E, Length_Check); 8861 else 8862 return Scope_Suppress.Suppress (Length_Check); 8863 end if; 8864 end Length_Checks_Suppressed; 8865 8866 ----------------------- 8867 -- Make_Bignum_Block -- 8868 ----------------------- 8869 8870 function Make_Bignum_Block (Loc : Source_Ptr) return Node_Id is 8871 M : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uM); 8872 begin 8873 return 8874 Make_Block_Statement (Loc, 8875 Declarations => 8876 New_List (Build_SS_Mark_Call (Loc, M)), 8877 Handled_Statement_Sequence => 8878 Make_Handled_Sequence_Of_Statements (Loc, 8879 Statements => New_List (Build_SS_Release_Call (Loc, M)))); 8880 end Make_Bignum_Block; 8881 8882 ---------------------------------- 8883 -- Minimize_Eliminate_Overflows -- 8884 ---------------------------------- 8885 8886 -- This is a recursive routine that is called at the top of an expression 8887 -- tree to properly process overflow checking for a whole subtree by making 8888 -- recursive calls to process operands. This processing may involve the use 8889 -- of bignum or long long integer arithmetic, which will change the types 8890 -- of operands and results. That's why we can't do this bottom up (since 8891 -- it would interfere with semantic analysis). 8892 8893 -- What happens is that if MINIMIZED/ELIMINATED mode is in effect then 8894 -- the operator expansion routines, as well as the expansion routines for 8895 -- if/case expression, do nothing (for the moment) except call the routine 8896 -- to apply the overflow check (Apply_Arithmetic_Overflow_Check). That 8897 -- routine does nothing for non top-level nodes, so at the point where the 8898 -- call is made for the top level node, the entire expression subtree has 8899 -- not been expanded, or processed for overflow. All that has to happen as 8900 -- a result of the top level call to this routine. 8901 8902 -- As noted above, the overflow processing works by making recursive calls 8903 -- for the operands, and figuring out what to do, based on the processing 8904 -- of these operands (e.g. if a bignum operand appears, the parent op has 8905 -- to be done in bignum mode), and the determined ranges of the operands. 8906 8907 -- After possible rewriting of a constituent subexpression node, a call is 8908 -- made to either reexpand the node (if nothing has changed) or reanalyze 8909 -- the node (if it has been modified by the overflow check processing). The 8910 -- Analyzed_Flag is set to False before the reexpand/reanalyze. To avoid 8911 -- a recursive call into the whole overflow apparatus, an important rule 8912 -- for this call is that the overflow handling mode must be temporarily set 8913 -- to STRICT. 8914 8915 procedure Minimize_Eliminate_Overflows 8916 (N : Node_Id; 8917 Lo : out Uint; 8918 Hi : out Uint; 8919 Top_Level : Boolean) 8920 is 8921 Rtyp : constant Entity_Id := Etype (N); 8922 pragma Assert (Is_Signed_Integer_Type (Rtyp)); 8923 -- Result type, must be a signed integer type 8924 8925 Check_Mode : constant Overflow_Mode_Type := Overflow_Check_Mode; 8926 pragma Assert (Check_Mode in Minimized_Or_Eliminated); 8927 8928 Loc : constant Source_Ptr := Sloc (N); 8929 8930 Rlo, Rhi : Uint; 8931 -- Ranges of values for right operand (operator case) 8932 8933 Llo : Uint := No_Uint; -- initialize to prevent warning 8934 Lhi : Uint := No_Uint; -- initialize to prevent warning 8935 -- Ranges of values for left operand (operator case) 8936 8937 LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer); 8938 -- Operands and results are of this type when we convert 8939 8940 LLLo : constant Uint := Intval (Type_Low_Bound (LLIB)); 8941 LLHi : constant Uint := Intval (Type_High_Bound (LLIB)); 8942 -- Bounds of Long_Long_Integer 8943 8944 Binary : constant Boolean := Nkind (N) in N_Binary_Op; 8945 -- Indicates binary operator case 8946 8947 OK : Boolean; 8948 -- Used in call to Determine_Range 8949 8950 Bignum_Operands : Boolean; 8951 -- Set True if one or more operands is already of type Bignum, meaning 8952 -- that for sure (regardless of Top_Level setting) we are committed to 8953 -- doing the operation in Bignum mode (or in the case of a case or if 8954 -- expression, converting all the dependent expressions to Bignum). 8955 8956 Long_Long_Integer_Operands : Boolean; 8957 -- Set True if one or more operands is already of type Long_Long_Integer 8958 -- which means that if the result is known to be in the result type 8959 -- range, then we must convert such operands back to the result type. 8960 8961 procedure Reanalyze (Typ : Entity_Id; Suppress : Boolean := False); 8962 -- This is called when we have modified the node and we therefore need 8963 -- to reanalyze it. It is important that we reset the mode to STRICT for 8964 -- this reanalysis, since if we leave it in MINIMIZED or ELIMINATED mode 8965 -- we would reenter this routine recursively which would not be good. 8966 -- The argument Suppress is set True if we also want to suppress 8967 -- overflow checking for the reexpansion (this is set when we know 8968 -- overflow is not possible). Typ is the type for the reanalysis. 8969 8970 procedure Reexpand (Suppress : Boolean := False); 8971 -- This is like Reanalyze, but does not do the Analyze step, it only 8972 -- does a reexpansion. We do this reexpansion in STRICT mode, so that 8973 -- instead of reentering the MINIMIZED/ELIMINATED mode processing, we 8974 -- follow the normal expansion path (e.g. converting A**4 to A**2**2). 8975 -- Note that skipping reanalysis is not just an optimization, testing 8976 -- has showed up several complex cases in which reanalyzing an already 8977 -- analyzed node causes incorrect behavior. 8978 8979 function In_Result_Range return Boolean; 8980 -- Returns True iff Lo .. Hi are within range of the result type 8981 8982 procedure Max (A : in out Uint; B : Uint); 8983 -- If A is No_Uint, sets A to B, else to UI_Max (A, B) 8984 8985 procedure Min (A : in out Uint; B : Uint); 8986 -- If A is No_Uint, sets A to B, else to UI_Min (A, B) 8987 8988 --------------------- 8989 -- In_Result_Range -- 8990 --------------------- 8991 8992 function In_Result_Range return Boolean is 8993 begin 8994 if Lo = No_Uint or else Hi = No_Uint then 8995 return False; 8996 8997 elsif Is_OK_Static_Subtype (Etype (N)) then 8998 return Lo >= Expr_Value (Type_Low_Bound (Rtyp)) 8999 and then 9000 Hi <= Expr_Value (Type_High_Bound (Rtyp)); 9001 9002 else 9003 return Lo >= Expr_Value (Type_Low_Bound (Base_Type (Rtyp))) 9004 and then 9005 Hi <= Expr_Value (Type_High_Bound (Base_Type (Rtyp))); 9006 end if; 9007 end In_Result_Range; 9008 9009 --------- 9010 -- Max -- 9011 --------- 9012 9013 procedure Max (A : in out Uint; B : Uint) is 9014 begin 9015 if A = No_Uint or else B > A then 9016 A := B; 9017 end if; 9018 end Max; 9019 9020 --------- 9021 -- Min -- 9022 --------- 9023 9024 procedure Min (A : in out Uint; B : Uint) is 9025 begin 9026 if A = No_Uint or else B < A then 9027 A := B; 9028 end if; 9029 end Min; 9030 9031 --------------- 9032 -- Reanalyze -- 9033 --------------- 9034 9035 procedure Reanalyze (Typ : Entity_Id; Suppress : Boolean := False) is 9036 Svg : constant Overflow_Mode_Type := 9037 Scope_Suppress.Overflow_Mode_General; 9038 Sva : constant Overflow_Mode_Type := 9039 Scope_Suppress.Overflow_Mode_Assertions; 9040 Svo : constant Boolean := 9041 Scope_Suppress.Suppress (Overflow_Check); 9042 9043 begin 9044 Scope_Suppress.Overflow_Mode_General := Strict; 9045 Scope_Suppress.Overflow_Mode_Assertions := Strict; 9046 9047 if Suppress then 9048 Scope_Suppress.Suppress (Overflow_Check) := True; 9049 end if; 9050 9051 Analyze_And_Resolve (N, Typ); 9052 9053 Scope_Suppress.Suppress (Overflow_Check) := Svo; 9054 Scope_Suppress.Overflow_Mode_General := Svg; 9055 Scope_Suppress.Overflow_Mode_Assertions := Sva; 9056 end Reanalyze; 9057 9058 -------------- 9059 -- Reexpand -- 9060 -------------- 9061 9062 procedure Reexpand (Suppress : Boolean := False) is 9063 Svg : constant Overflow_Mode_Type := 9064 Scope_Suppress.Overflow_Mode_General; 9065 Sva : constant Overflow_Mode_Type := 9066 Scope_Suppress.Overflow_Mode_Assertions; 9067 Svo : constant Boolean := 9068 Scope_Suppress.Suppress (Overflow_Check); 9069 9070 begin 9071 Scope_Suppress.Overflow_Mode_General := Strict; 9072 Scope_Suppress.Overflow_Mode_Assertions := Strict; 9073 Set_Analyzed (N, False); 9074 9075 if Suppress then 9076 Scope_Suppress.Suppress (Overflow_Check) := True; 9077 end if; 9078 9079 Expand (N); 9080 9081 Scope_Suppress.Suppress (Overflow_Check) := Svo; 9082 Scope_Suppress.Overflow_Mode_General := Svg; 9083 Scope_Suppress.Overflow_Mode_Assertions := Sva; 9084 end Reexpand; 9085 9086 -- Start of processing for Minimize_Eliminate_Overflows 9087 9088 begin 9089 -- Default initialize Lo and Hi since these are not guaranteed to be 9090 -- set otherwise. 9091 9092 Lo := No_Uint; 9093 Hi := No_Uint; 9094 9095 -- Case where we do not have a signed integer arithmetic operation 9096 9097 if not Is_Signed_Integer_Arithmetic_Op (N) then 9098 9099 -- Use the normal Determine_Range routine to get the range. We 9100 -- don't require operands to be valid, invalid values may result in 9101 -- rubbish results where the result has not been properly checked for 9102 -- overflow, that's fine. 9103 9104 Determine_Range (N, OK, Lo, Hi, Assume_Valid => False); 9105 9106 -- If Determine_Range did not work (can this in fact happen? Not 9107 -- clear but might as well protect), use type bounds. 9108 9109 if not OK then 9110 Lo := Intval (Type_Low_Bound (Base_Type (Etype (N)))); 9111 Hi := Intval (Type_High_Bound (Base_Type (Etype (N)))); 9112 end if; 9113 9114 -- If we don't have a binary operator, all we have to do is to set 9115 -- the Hi/Lo range, so we are done. 9116 9117 return; 9118 9119 -- Processing for if expression 9120 9121 elsif Nkind (N) = N_If_Expression then 9122 declare 9123 Then_DE : constant Node_Id := Next (First (Expressions (N))); 9124 Else_DE : constant Node_Id := Next (Then_DE); 9125 9126 begin 9127 Bignum_Operands := False; 9128 9129 Minimize_Eliminate_Overflows 9130 (Then_DE, Lo, Hi, Top_Level => False); 9131 9132 if Lo = No_Uint then 9133 Bignum_Operands := True; 9134 end if; 9135 9136 Minimize_Eliminate_Overflows 9137 (Else_DE, Rlo, Rhi, Top_Level => False); 9138 9139 if Rlo = No_Uint then 9140 Bignum_Operands := True; 9141 else 9142 Long_Long_Integer_Operands := 9143 Etype (Then_DE) = LLIB or else Etype (Else_DE) = LLIB; 9144 9145 Min (Lo, Rlo); 9146 Max (Hi, Rhi); 9147 end if; 9148 9149 -- If at least one of our operands is now Bignum, we must rebuild 9150 -- the if expression to use Bignum operands. We will analyze the 9151 -- rebuilt if expression with overflow checks off, since once we 9152 -- are in bignum mode, we are all done with overflow checks. 9153 9154 if Bignum_Operands then 9155 Rewrite (N, 9156 Make_If_Expression (Loc, 9157 Expressions => New_List ( 9158 Remove_Head (Expressions (N)), 9159 Convert_To_Bignum (Then_DE), 9160 Convert_To_Bignum (Else_DE)), 9161 Is_Elsif => Is_Elsif (N))); 9162 9163 Reanalyze (RTE (RE_Bignum), Suppress => True); 9164 9165 -- If we have no Long_Long_Integer operands, then we are in result 9166 -- range, since it means that none of our operands felt the need 9167 -- to worry about overflow (otherwise it would have already been 9168 -- converted to long long integer or bignum). We reexpand to 9169 -- complete the expansion of the if expression (but we do not 9170 -- need to reanalyze). 9171 9172 elsif not Long_Long_Integer_Operands then 9173 Set_Do_Overflow_Check (N, False); 9174 Reexpand; 9175 9176 -- Otherwise convert us to long long integer mode. Note that we 9177 -- don't need any further overflow checking at this level. 9178 9179 else 9180 Convert_To_And_Rewrite (LLIB, Then_DE); 9181 Convert_To_And_Rewrite (LLIB, Else_DE); 9182 Set_Etype (N, LLIB); 9183 9184 -- Now reanalyze with overflow checks off 9185 9186 Set_Do_Overflow_Check (N, False); 9187 Reanalyze (LLIB, Suppress => True); 9188 end if; 9189 end; 9190 9191 return; 9192 9193 -- Here for case expression 9194 9195 elsif Nkind (N) = N_Case_Expression then 9196 Bignum_Operands := False; 9197 Long_Long_Integer_Operands := False; 9198 9199 declare 9200 Alt : Node_Id; 9201 9202 begin 9203 -- Loop through expressions applying recursive call 9204 9205 Alt := First (Alternatives (N)); 9206 while Present (Alt) loop 9207 declare 9208 Aexp : constant Node_Id := Expression (Alt); 9209 9210 begin 9211 Minimize_Eliminate_Overflows 9212 (Aexp, Lo, Hi, Top_Level => False); 9213 9214 if Lo = No_Uint then 9215 Bignum_Operands := True; 9216 elsif Etype (Aexp) = LLIB then 9217 Long_Long_Integer_Operands := True; 9218 end if; 9219 end; 9220 9221 Next (Alt); 9222 end loop; 9223 9224 -- If we have no bignum or long long integer operands, it means 9225 -- that none of our dependent expressions could raise overflow. 9226 -- In this case, we simply return with no changes except for 9227 -- resetting the overflow flag, since we are done with overflow 9228 -- checks for this node. We will reexpand to get the needed 9229 -- expansion for the case expression, but we do not need to 9230 -- reanalyze, since nothing has changed. 9231 9232 if not (Bignum_Operands or Long_Long_Integer_Operands) then 9233 Set_Do_Overflow_Check (N, False); 9234 Reexpand (Suppress => True); 9235 9236 -- Otherwise we are going to rebuild the case expression using 9237 -- either bignum or long long integer operands throughout. 9238 9239 else 9240 declare 9241 Rtype : Entity_Id := Empty; 9242 New_Alts : List_Id; 9243 New_Exp : Node_Id; 9244 9245 begin 9246 New_Alts := New_List; 9247 Alt := First (Alternatives (N)); 9248 while Present (Alt) loop 9249 if Bignum_Operands then 9250 New_Exp := Convert_To_Bignum (Expression (Alt)); 9251 Rtype := RTE (RE_Bignum); 9252 else 9253 New_Exp := Convert_To (LLIB, Expression (Alt)); 9254 Rtype := LLIB; 9255 end if; 9256 9257 Append_To (New_Alts, 9258 Make_Case_Expression_Alternative (Sloc (Alt), 9259 Actions => No_List, 9260 Discrete_Choices => Discrete_Choices (Alt), 9261 Expression => New_Exp)); 9262 9263 Next (Alt); 9264 end loop; 9265 9266 Rewrite (N, 9267 Make_Case_Expression (Loc, 9268 Expression => Expression (N), 9269 Alternatives => New_Alts)); 9270 9271 pragma Assert (Present (Rtype)); 9272 Reanalyze (Rtype, Suppress => True); 9273 end; 9274 end if; 9275 end; 9276 9277 return; 9278 end if; 9279 9280 -- If we have an arithmetic operator we make recursive calls on the 9281 -- operands to get the ranges (and to properly process the subtree 9282 -- that lies below us). 9283 9284 Minimize_Eliminate_Overflows 9285 (Right_Opnd (N), Rlo, Rhi, Top_Level => False); 9286 9287 if Binary then 9288 Minimize_Eliminate_Overflows 9289 (Left_Opnd (N), Llo, Lhi, Top_Level => False); 9290 end if; 9291 9292 -- Record if we have Long_Long_Integer operands 9293 9294 Long_Long_Integer_Operands := 9295 Etype (Right_Opnd (N)) = LLIB 9296 or else (Binary and then Etype (Left_Opnd (N)) = LLIB); 9297 9298 -- If either operand is a bignum, then result will be a bignum and we 9299 -- don't need to do any range analysis. As previously discussed we could 9300 -- do range analysis in such cases, but it could mean working with giant 9301 -- numbers at compile time for very little gain (the number of cases 9302 -- in which we could slip back from bignum mode is small). 9303 9304 if Rlo = No_Uint or else (Binary and then Llo = No_Uint) then 9305 Lo := No_Uint; 9306 Hi := No_Uint; 9307 Bignum_Operands := True; 9308 9309 -- Otherwise compute result range 9310 9311 else 9312 Compute_Range_For_Arithmetic_Op 9313 (Nkind (N), Llo, Lhi, Rlo, Rhi, OK, Lo, Hi); 9314 Bignum_Operands := False; 9315 end if; 9316 9317 -- Here for the case where we have not rewritten anything (no bignum 9318 -- operands or long long integer operands), and we know the result. 9319 -- If we know we are in the result range, and we do not have Bignum 9320 -- operands or Long_Long_Integer operands, we can just reexpand with 9321 -- overflow checks turned off (since we know we cannot have overflow). 9322 -- As always the reexpansion is required to complete expansion of the 9323 -- operator, but we do not need to reanalyze, and we prevent recursion 9324 -- by suppressing the check. 9325 9326 if not (Bignum_Operands or Long_Long_Integer_Operands) 9327 and then In_Result_Range 9328 then 9329 Set_Do_Overflow_Check (N, False); 9330 Reexpand (Suppress => True); 9331 return; 9332 9333 -- Here we know that we are not in the result range, and in the general 9334 -- case we will move into either the Bignum or Long_Long_Integer domain 9335 -- to compute the result. However, there is one exception. If we are 9336 -- at the top level, and we do not have Bignum or Long_Long_Integer 9337 -- operands, we will have to immediately convert the result back to 9338 -- the result type, so there is no point in Bignum/Long_Long_Integer 9339 -- fiddling. 9340 9341 elsif Top_Level 9342 and then not (Bignum_Operands or Long_Long_Integer_Operands) 9343 9344 -- One further refinement. If we are at the top level, but our parent 9345 -- is a type conversion, then go into bignum or long long integer node 9346 -- since the result will be converted to that type directly without 9347 -- going through the result type, and we may avoid an overflow. This 9348 -- is the case for example of Long_Long_Integer (A ** 4), where A is 9349 -- of type Integer, and the result A ** 4 fits in Long_Long_Integer 9350 -- but does not fit in Integer. 9351 9352 and then Nkind (Parent (N)) /= N_Type_Conversion 9353 then 9354 -- Here keep original types, but we need to complete analysis 9355 9356 -- One subtlety. We can't just go ahead and do an analyze operation 9357 -- here because it will cause recursion into the whole MINIMIZED/ 9358 -- ELIMINATED overflow processing which is not what we want. Here 9359 -- we are at the top level, and we need a check against the result 9360 -- mode (i.e. we want to use STRICT mode). So do exactly that. 9361 -- Also, we have not modified the node, so this is a case where 9362 -- we need to reexpand, but not reanalyze. 9363 9364 Reexpand; 9365 return; 9366 9367 -- Cases where we do the operation in Bignum mode. This happens either 9368 -- because one of our operands is in Bignum mode already, or because 9369 -- the computed bounds are outside the bounds of Long_Long_Integer, 9370 -- which in some cases can be indicated by Hi and Lo being No_Uint. 9371 9372 -- Note: we could do better here and in some cases switch back from 9373 -- Bignum mode to normal mode, e.g. big mod 2 must be in the range 9374 -- 0 .. 1, but the cases are rare and it is not worth the effort. 9375 -- Failing to do this switching back is only an efficiency issue. 9376 9377 elsif Lo = No_Uint or else Lo < LLLo or else Hi > LLHi then 9378 9379 -- OK, we are definitely outside the range of Long_Long_Integer. The 9380 -- question is whether to move to Bignum mode, or stay in the domain 9381 -- of Long_Long_Integer, signalling that an overflow check is needed. 9382 9383 -- Obviously in MINIMIZED mode we stay with LLI, since we are not in 9384 -- the Bignum business. In ELIMINATED mode, we will normally move 9385 -- into Bignum mode, but there is an exception if neither of our 9386 -- operands is Bignum now, and we are at the top level (Top_Level 9387 -- set True). In this case, there is no point in moving into Bignum 9388 -- mode to prevent overflow if the caller will immediately convert 9389 -- the Bignum value back to LLI with an overflow check. It's more 9390 -- efficient to stay in LLI mode with an overflow check (if needed) 9391 9392 if Check_Mode = Minimized 9393 or else (Top_Level and not Bignum_Operands) 9394 then 9395 if Do_Overflow_Check (N) then 9396 Enable_Overflow_Check (N); 9397 end if; 9398 9399 -- The result now has to be in Long_Long_Integer mode, so adjust 9400 -- the possible range to reflect this. Note these calls also 9401 -- change No_Uint values from the top level case to LLI bounds. 9402 9403 Max (Lo, LLLo); 9404 Min (Hi, LLHi); 9405 9406 -- Otherwise we are in ELIMINATED mode and we switch to Bignum mode 9407 9408 else 9409 pragma Assert (Check_Mode = Eliminated); 9410 9411 declare 9412 Fent : Entity_Id; 9413 Args : List_Id; 9414 9415 begin 9416 case Nkind (N) is 9417 when N_Op_Abs => 9418 Fent := RTE (RE_Big_Abs); 9419 9420 when N_Op_Add => 9421 Fent := RTE (RE_Big_Add); 9422 9423 when N_Op_Divide => 9424 Fent := RTE (RE_Big_Div); 9425 9426 when N_Op_Expon => 9427 Fent := RTE (RE_Big_Exp); 9428 9429 when N_Op_Minus => 9430 Fent := RTE (RE_Big_Neg); 9431 9432 when N_Op_Mod => 9433 Fent := RTE (RE_Big_Mod); 9434 9435 when N_Op_Multiply => 9436 Fent := RTE (RE_Big_Mul); 9437 9438 when N_Op_Rem => 9439 Fent := RTE (RE_Big_Rem); 9440 9441 when N_Op_Subtract => 9442 Fent := RTE (RE_Big_Sub); 9443 9444 -- Anything else is an internal error, this includes the 9445 -- N_Op_Plus case, since how can plus cause the result 9446 -- to be out of range if the operand is in range? 9447 9448 when others => 9449 raise Program_Error; 9450 end case; 9451 9452 -- Construct argument list for Bignum call, converting our 9453 -- operands to Bignum form if they are not already there. 9454 9455 Args := New_List; 9456 9457 if Binary then 9458 Append_To (Args, Convert_To_Bignum (Left_Opnd (N))); 9459 end if; 9460 9461 Append_To (Args, Convert_To_Bignum (Right_Opnd (N))); 9462 9463 -- Now rewrite the arithmetic operator with a call to the 9464 -- corresponding bignum function. 9465 9466 Rewrite (N, 9467 Make_Function_Call (Loc, 9468 Name => New_Occurrence_Of (Fent, Loc), 9469 Parameter_Associations => Args)); 9470 Reanalyze (RTE (RE_Bignum), Suppress => True); 9471 9472 -- Indicate result is Bignum mode 9473 9474 Lo := No_Uint; 9475 Hi := No_Uint; 9476 return; 9477 end; 9478 end if; 9479 9480 -- Otherwise we are in range of Long_Long_Integer, so no overflow 9481 -- check is required, at least not yet. 9482 9483 else 9484 Set_Do_Overflow_Check (N, False); 9485 end if; 9486 9487 -- Here we are not in Bignum territory, but we may have long long 9488 -- integer operands that need special handling. First a special check: 9489 -- If an exponentiation operator exponent is of type Long_Long_Integer, 9490 -- it means we converted it to prevent overflow, but exponentiation 9491 -- requires a Natural right operand, so convert it back to Natural. 9492 -- This conversion may raise an exception which is fine. 9493 9494 if Nkind (N) = N_Op_Expon and then Etype (Right_Opnd (N)) = LLIB then 9495 Convert_To_And_Rewrite (Standard_Natural, Right_Opnd (N)); 9496 end if; 9497 9498 -- Here we will do the operation in Long_Long_Integer. We do this even 9499 -- if we know an overflow check is required, better to do this in long 9500 -- long integer mode, since we are less likely to overflow. 9501 9502 -- Convert right or only operand to Long_Long_Integer, except that 9503 -- we do not touch the exponentiation right operand. 9504 9505 if Nkind (N) /= N_Op_Expon then 9506 Convert_To_And_Rewrite (LLIB, Right_Opnd (N)); 9507 end if; 9508 9509 -- Convert left operand to Long_Long_Integer for binary case 9510 9511 if Binary then 9512 Convert_To_And_Rewrite (LLIB, Left_Opnd (N)); 9513 end if; 9514 9515 -- Reset node to unanalyzed 9516 9517 Set_Analyzed (N, False); 9518 Set_Etype (N, Empty); 9519 Set_Entity (N, Empty); 9520 9521 -- Now analyze this new node. This reanalysis will complete processing 9522 -- for the node. In particular we will complete the expansion of an 9523 -- exponentiation operator (e.g. changing A ** 2 to A * A), and also 9524 -- we will complete any division checks (since we have not changed the 9525 -- setting of the Do_Division_Check flag). 9526 9527 -- We do this reanalysis in STRICT mode to avoid recursion into the 9528 -- MINIMIZED/ELIMINATED handling, since we are now done with that. 9529 9530 declare 9531 SG : constant Overflow_Mode_Type := 9532 Scope_Suppress.Overflow_Mode_General; 9533 SA : constant Overflow_Mode_Type := 9534 Scope_Suppress.Overflow_Mode_Assertions; 9535 9536 begin 9537 Scope_Suppress.Overflow_Mode_General := Strict; 9538 Scope_Suppress.Overflow_Mode_Assertions := Strict; 9539 9540 if not Do_Overflow_Check (N) then 9541 Reanalyze (LLIB, Suppress => True); 9542 else 9543 Reanalyze (LLIB); 9544 end if; 9545 9546 Scope_Suppress.Overflow_Mode_General := SG; 9547 Scope_Suppress.Overflow_Mode_Assertions := SA; 9548 end; 9549 end Minimize_Eliminate_Overflows; 9550 9551 ------------------------- 9552 -- Overflow_Check_Mode -- 9553 ------------------------- 9554 9555 function Overflow_Check_Mode return Overflow_Mode_Type is 9556 begin 9557 if In_Assertion_Expr = 0 then 9558 return Scope_Suppress.Overflow_Mode_General; 9559 else 9560 return Scope_Suppress.Overflow_Mode_Assertions; 9561 end if; 9562 end Overflow_Check_Mode; 9563 9564 -------------------------------- 9565 -- Overflow_Checks_Suppressed -- 9566 -------------------------------- 9567 9568 function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is 9569 begin 9570 if Present (E) and then Checks_May_Be_Suppressed (E) then 9571 return Is_Check_Suppressed (E, Overflow_Check); 9572 else 9573 return Scope_Suppress.Suppress (Overflow_Check); 9574 end if; 9575 end Overflow_Checks_Suppressed; 9576 9577 --------------------------------- 9578 -- Predicate_Checks_Suppressed -- 9579 --------------------------------- 9580 9581 function Predicate_Checks_Suppressed (E : Entity_Id) return Boolean is 9582 begin 9583 if Present (E) and then Checks_May_Be_Suppressed (E) then 9584 return Is_Check_Suppressed (E, Predicate_Check); 9585 else 9586 return Scope_Suppress.Suppress (Predicate_Check); 9587 end if; 9588 end Predicate_Checks_Suppressed; 9589 9590 ----------------------------- 9591 -- Range_Checks_Suppressed -- 9592 ----------------------------- 9593 9594 function Range_Checks_Suppressed (E : Entity_Id) return Boolean is 9595 begin 9596 if Present (E) then 9597 if Kill_Range_Checks (E) then 9598 return True; 9599 9600 elsif Checks_May_Be_Suppressed (E) then 9601 return Is_Check_Suppressed (E, Range_Check); 9602 end if; 9603 end if; 9604 9605 return Scope_Suppress.Suppress (Range_Check); 9606 end Range_Checks_Suppressed; 9607 9608 ----------------------------------------- 9609 -- Range_Or_Validity_Checks_Suppressed -- 9610 ----------------------------------------- 9611 9612 -- Note: the coding would be simpler here if we simply made appropriate 9613 -- calls to Range/Validity_Checks_Suppressed, but that would result in 9614 -- duplicated checks which we prefer to avoid. 9615 9616 function Range_Or_Validity_Checks_Suppressed 9617 (Expr : Node_Id) return Boolean 9618 is 9619 begin 9620 -- Immediate return if scope checks suppressed for either check 9621 9622 if Scope_Suppress.Suppress (Range_Check) 9623 or 9624 Scope_Suppress.Suppress (Validity_Check) 9625 then 9626 return True; 9627 end if; 9628 9629 -- If no expression, that's odd, decide that checks are suppressed, 9630 -- since we don't want anyone trying to do checks in this case, which 9631 -- is most likely the result of some other error. 9632 9633 if No (Expr) then 9634 return True; 9635 end if; 9636 9637 -- Expression is present, so perform suppress checks on type 9638 9639 declare 9640 Typ : constant Entity_Id := Etype (Expr); 9641 begin 9642 if Checks_May_Be_Suppressed (Typ) 9643 and then (Is_Check_Suppressed (Typ, Range_Check) 9644 or else 9645 Is_Check_Suppressed (Typ, Validity_Check)) 9646 then 9647 return True; 9648 end if; 9649 end; 9650 9651 -- If expression is an entity name, perform checks on this entity 9652 9653 if Is_Entity_Name (Expr) then 9654 declare 9655 Ent : constant Entity_Id := Entity (Expr); 9656 begin 9657 if Checks_May_Be_Suppressed (Ent) then 9658 return Is_Check_Suppressed (Ent, Range_Check) 9659 or else Is_Check_Suppressed (Ent, Validity_Check); 9660 end if; 9661 end; 9662 end if; 9663 9664 -- If we fall through, no checks suppressed 9665 9666 return False; 9667 end Range_Or_Validity_Checks_Suppressed; 9668 9669 ------------------- 9670 -- Remove_Checks -- 9671 ------------------- 9672 9673 procedure Remove_Checks (Expr : Node_Id) is 9674 function Process (N : Node_Id) return Traverse_Result; 9675 -- Process a single node during the traversal 9676 9677 procedure Traverse is new Traverse_Proc (Process); 9678 -- The traversal procedure itself 9679 9680 ------------- 9681 -- Process -- 9682 ------------- 9683 9684 function Process (N : Node_Id) return Traverse_Result is 9685 begin 9686 if Nkind (N) not in N_Subexpr then 9687 return Skip; 9688 end if; 9689 9690 Set_Do_Range_Check (N, False); 9691 9692 case Nkind (N) is 9693 when N_And_Then => 9694 Traverse (Left_Opnd (N)); 9695 return Skip; 9696 9697 when N_Attribute_Reference => 9698 Set_Do_Overflow_Check (N, False); 9699 9700 when N_Function_Call => 9701 Set_Do_Tag_Check (N, False); 9702 9703 when N_Op => 9704 Set_Do_Overflow_Check (N, False); 9705 9706 case Nkind (N) is 9707 when N_Op_Divide => 9708 Set_Do_Division_Check (N, False); 9709 9710 when N_Op_And => 9711 Set_Do_Length_Check (N, False); 9712 9713 when N_Op_Mod => 9714 Set_Do_Division_Check (N, False); 9715 9716 when N_Op_Or => 9717 Set_Do_Length_Check (N, False); 9718 9719 when N_Op_Rem => 9720 Set_Do_Division_Check (N, False); 9721 9722 when N_Op_Xor => 9723 Set_Do_Length_Check (N, False); 9724 9725 when others => 9726 null; 9727 end case; 9728 9729 when N_Or_Else => 9730 Traverse (Left_Opnd (N)); 9731 return Skip; 9732 9733 when N_Selected_Component => 9734 Set_Do_Discriminant_Check (N, False); 9735 9736 when N_Type_Conversion => 9737 Set_Do_Length_Check (N, False); 9738 Set_Do_Tag_Check (N, False); 9739 Set_Do_Overflow_Check (N, False); 9740 9741 when others => 9742 null; 9743 end case; 9744 9745 return OK; 9746 end Process; 9747 9748 -- Start of processing for Remove_Checks 9749 9750 begin 9751 Traverse (Expr); 9752 end Remove_Checks; 9753 9754 ---------------------------- 9755 -- Selected_Length_Checks -- 9756 ---------------------------- 9757 9758 function Selected_Length_Checks 9759 (Expr : Node_Id; 9760 Target_Typ : Entity_Id; 9761 Source_Typ : Entity_Id; 9762 Warn_Node : Node_Id) return Check_Result 9763 is 9764 Loc : constant Source_Ptr := Sloc (Expr); 9765 S_Typ : Entity_Id; 9766 T_Typ : Entity_Id; 9767 Expr_Actual : Node_Id; 9768 Exptyp : Entity_Id; 9769 Cond : Node_Id := Empty; 9770 Do_Access : Boolean := False; 9771 Wnode : Node_Id := Warn_Node; 9772 Ret_Result : Check_Result := (Empty, Empty); 9773 Num_Checks : Natural := 0; 9774 9775 procedure Add_Check (N : Node_Id); 9776 -- Adds the action given to Ret_Result if N is non-Empty 9777 9778 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id; 9779 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id; 9780 -- Comments required ??? 9781 9782 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean; 9783 -- True for equal literals and for nodes that denote the same constant 9784 -- entity, even if its value is not a static constant. This includes the 9785 -- case of a discriminal reference within an init proc. Removes some 9786 -- obviously superfluous checks. 9787 9788 function Length_E_Cond 9789 (Exptyp : Entity_Id; 9790 Typ : Entity_Id; 9791 Indx : Nat) return Node_Id; 9792 -- Returns expression to compute: 9793 -- Typ'Length /= Exptyp'Length 9794 9795 function Length_N_Cond 9796 (Exp : Node_Id; 9797 Typ : Entity_Id; 9798 Indx : Nat) return Node_Id; 9799 -- Returns expression to compute: 9800 -- Typ'Length /= Exp'Length 9801 9802 function Length_Mismatch_Info_Message 9803 (Left_Element_Count : Uint; 9804 Right_Element_Count : Uint) return String; 9805 -- Returns a message indicating how many elements were expected 9806 -- (Left_Element_Count) and how many were found (Right_Element_Count). 9807 9808 --------------- 9809 -- Add_Check -- 9810 --------------- 9811 9812 procedure Add_Check (N : Node_Id) is 9813 begin 9814 if Present (N) then 9815 9816 -- For now, ignore attempt to place more than two checks ??? 9817 -- This is really worrisome, are we really discarding checks ??? 9818 9819 if Num_Checks = 2 then 9820 return; 9821 end if; 9822 9823 pragma Assert (Num_Checks <= 1); 9824 Num_Checks := Num_Checks + 1; 9825 Ret_Result (Num_Checks) := N; 9826 end if; 9827 end Add_Check; 9828 9829 ------------------ 9830 -- Get_E_Length -- 9831 ------------------ 9832 9833 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is 9834 SE : constant Entity_Id := Scope (E); 9835 N : Node_Id; 9836 E1 : Entity_Id := E; 9837 9838 begin 9839 if Ekind (Scope (E)) = E_Record_Type 9840 and then Has_Discriminants (Scope (E)) 9841 then 9842 N := Build_Discriminal_Subtype_Of_Component (E); 9843 9844 if Present (N) then 9845 Insert_Action (Expr, N); 9846 E1 := Defining_Identifier (N); 9847 end if; 9848 end if; 9849 9850 if Ekind (E1) = E_String_Literal_Subtype then 9851 return 9852 Make_Integer_Literal (Loc, 9853 Intval => String_Literal_Length (E1)); 9854 9855 elsif SE /= Standard_Standard 9856 and then Ekind (Scope (SE)) = E_Protected_Type 9857 and then Has_Discriminants (Scope (SE)) 9858 and then Has_Completion (Scope (SE)) 9859 and then not Inside_Init_Proc 9860 then 9861 -- If the type whose length is needed is a private component 9862 -- constrained by a discriminant, we must expand the 'Length 9863 -- attribute into an explicit computation, using the discriminal 9864 -- of the current protected operation. This is because the actual 9865 -- type of the prival is constructed after the protected opera- 9866 -- tion has been fully expanded. 9867 9868 declare 9869 Indx_Type : Node_Id; 9870 Lo : Node_Id; 9871 Hi : Node_Id; 9872 Do_Expand : Boolean := False; 9873 9874 begin 9875 Indx_Type := First_Index (E); 9876 9877 for J in 1 .. Indx - 1 loop 9878 Next_Index (Indx_Type); 9879 end loop; 9880 9881 Get_Index_Bounds (Indx_Type, Lo, Hi); 9882 9883 if Nkind (Lo) = N_Identifier 9884 and then Ekind (Entity (Lo)) = E_In_Parameter 9885 then 9886 Lo := Get_Discriminal (E, Lo); 9887 Do_Expand := True; 9888 end if; 9889 9890 if Nkind (Hi) = N_Identifier 9891 and then Ekind (Entity (Hi)) = E_In_Parameter 9892 then 9893 Hi := Get_Discriminal (E, Hi); 9894 Do_Expand := True; 9895 end if; 9896 9897 if Do_Expand then 9898 if not Is_Entity_Name (Lo) then 9899 Lo := Duplicate_Subexpr_No_Checks (Lo); 9900 end if; 9901 9902 if not Is_Entity_Name (Hi) then 9903 Lo := Duplicate_Subexpr_No_Checks (Hi); 9904 end if; 9905 9906 N := 9907 Make_Op_Add (Loc, 9908 Left_Opnd => 9909 Make_Op_Subtract (Loc, 9910 Left_Opnd => Hi, 9911 Right_Opnd => Lo), 9912 9913 Right_Opnd => Make_Integer_Literal (Loc, 1)); 9914 return N; 9915 9916 else 9917 N := 9918 Make_Attribute_Reference (Loc, 9919 Attribute_Name => Name_Length, 9920 Prefix => 9921 New_Occurrence_Of (E1, Loc)); 9922 9923 if Indx > 1 then 9924 Set_Expressions (N, New_List ( 9925 Make_Integer_Literal (Loc, Indx))); 9926 end if; 9927 9928 return N; 9929 end if; 9930 end; 9931 9932 else 9933 N := 9934 Make_Attribute_Reference (Loc, 9935 Attribute_Name => Name_Length, 9936 Prefix => 9937 New_Occurrence_Of (E1, Loc)); 9938 9939 if Indx > 1 then 9940 Set_Expressions (N, New_List ( 9941 Make_Integer_Literal (Loc, Indx))); 9942 end if; 9943 9944 return N; 9945 end if; 9946 end Get_E_Length; 9947 9948 ------------------ 9949 -- Get_N_Length -- 9950 ------------------ 9951 9952 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is 9953 begin 9954 return 9955 Make_Attribute_Reference (Loc, 9956 Attribute_Name => Name_Length, 9957 Prefix => 9958 Duplicate_Subexpr_No_Checks (N, Name_Req => True), 9959 Expressions => New_List ( 9960 Make_Integer_Literal (Loc, Indx))); 9961 end Get_N_Length; 9962 9963 ------------------- 9964 -- Length_E_Cond -- 9965 ------------------- 9966 9967 function Length_E_Cond 9968 (Exptyp : Entity_Id; 9969 Typ : Entity_Id; 9970 Indx : Nat) return Node_Id 9971 is 9972 begin 9973 return 9974 Make_Op_Ne (Loc, 9975 Left_Opnd => Get_E_Length (Typ, Indx), 9976 Right_Opnd => Get_E_Length (Exptyp, Indx)); 9977 end Length_E_Cond; 9978 9979 ------------------- 9980 -- Length_N_Cond -- 9981 ------------------- 9982 9983 function Length_N_Cond 9984 (Exp : Node_Id; 9985 Typ : Entity_Id; 9986 Indx : Nat) return Node_Id 9987 is 9988 begin 9989 return 9990 Make_Op_Ne (Loc, 9991 Left_Opnd => Get_E_Length (Typ, Indx), 9992 Right_Opnd => Get_N_Length (Exp, Indx)); 9993 end Length_N_Cond; 9994 9995 ---------------------------------- 9996 -- Length_Mismatch_Info_Message -- 9997 ---------------------------------- 9998 9999 function Length_Mismatch_Info_Message 10000 (Left_Element_Count : Uint; 10001 Right_Element_Count : Uint) return String 10002 is 10003 10004 function Plural_Vs_Singular_Ending (Count : Uint) return String; 10005 -- Returns an empty string if Count is 1; otherwise returns "s" 10006 10007 function Plural_Vs_Singular_Ending (Count : Uint) return String is 10008 begin 10009 if Count = 1 then 10010 return ""; 10011 else 10012 return "s"; 10013 end if; 10014 end Plural_Vs_Singular_Ending; 10015 10016 begin 10017 return "expected " & UI_Image (Left_Element_Count) 10018 & " element" 10019 & Plural_Vs_Singular_Ending (Left_Element_Count) 10020 & "; found " & UI_Image (Right_Element_Count) 10021 & " element" 10022 & Plural_Vs_Singular_Ending (Right_Element_Count); 10023 end Length_Mismatch_Info_Message; 10024 10025 ----------------- 10026 -- Same_Bounds -- 10027 ----------------- 10028 10029 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is 10030 begin 10031 return 10032 (Nkind (L) = N_Integer_Literal 10033 and then Nkind (R) = N_Integer_Literal 10034 and then Intval (L) = Intval (R)) 10035 10036 or else 10037 (Is_Entity_Name (L) 10038 and then Ekind (Entity (L)) = E_Constant 10039 and then ((Is_Entity_Name (R) 10040 and then Entity (L) = Entity (R)) 10041 or else 10042 (Nkind (R) = N_Type_Conversion 10043 and then Is_Entity_Name (Expression (R)) 10044 and then Entity (L) = Entity (Expression (R))))) 10045 10046 or else 10047 (Is_Entity_Name (R) 10048 and then Ekind (Entity (R)) = E_Constant 10049 and then Nkind (L) = N_Type_Conversion 10050 and then Is_Entity_Name (Expression (L)) 10051 and then Entity (R) = Entity (Expression (L))) 10052 10053 or else 10054 (Is_Entity_Name (L) 10055 and then Is_Entity_Name (R) 10056 and then Entity (L) = Entity (R) 10057 and then Ekind (Entity (L)) = E_In_Parameter 10058 and then Inside_Init_Proc); 10059 end Same_Bounds; 10060 10061 -- Start of processing for Selected_Length_Checks 10062 10063 begin 10064 -- Checks will be applied only when generating code 10065 10066 if not Expander_Active then 10067 return Ret_Result; 10068 end if; 10069 10070 if Target_Typ = Any_Type 10071 or else Target_Typ = Any_Composite 10072 or else Raises_Constraint_Error (Expr) 10073 then 10074 return Ret_Result; 10075 end if; 10076 10077 if No (Wnode) then 10078 Wnode := Expr; 10079 end if; 10080 10081 T_Typ := Target_Typ; 10082 10083 if No (Source_Typ) then 10084 S_Typ := Etype (Expr); 10085 else 10086 S_Typ := Source_Typ; 10087 end if; 10088 10089 if S_Typ = Any_Type or else S_Typ = Any_Composite then 10090 return Ret_Result; 10091 end if; 10092 10093 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then 10094 S_Typ := Designated_Type (S_Typ); 10095 T_Typ := Designated_Type (T_Typ); 10096 Do_Access := True; 10097 10098 -- A simple optimization for the null case 10099 10100 if Known_Null (Expr) then 10101 return Ret_Result; 10102 end if; 10103 end if; 10104 10105 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then 10106 if Is_Constrained (T_Typ) then 10107 10108 -- The checking code to be generated will freeze the corresponding 10109 -- array type. However, we must freeze the type now, so that the 10110 -- freeze node does not appear within the generated if expression, 10111 -- but ahead of it. 10112 10113 Freeze_Before (Expr, T_Typ); 10114 10115 Expr_Actual := Get_Referenced_Object (Expr); 10116 Exptyp := Get_Actual_Subtype (Expr); 10117 10118 if Is_Access_Type (Exptyp) then 10119 Exptyp := Designated_Type (Exptyp); 10120 end if; 10121 10122 -- String_Literal case. This needs to be handled specially be- 10123 -- cause no index types are available for string literals. The 10124 -- condition is simply: 10125 10126 -- T_Typ'Length = string-literal-length 10127 10128 if Nkind (Expr_Actual) = N_String_Literal 10129 and then Ekind (Etype (Expr_Actual)) = E_String_Literal_Subtype 10130 then 10131 Cond := 10132 Make_Op_Ne (Loc, 10133 Left_Opnd => Get_E_Length (T_Typ, 1), 10134 Right_Opnd => 10135 Make_Integer_Literal (Loc, 10136 Intval => 10137 String_Literal_Length (Etype (Expr_Actual)))); 10138 10139 -- General array case. Here we have a usable actual subtype for 10140 -- the expression, and the condition is built from the two types 10141 -- (Do_Length): 10142 10143 -- T_Typ'Length /= Exptyp'Length or else 10144 -- T_Typ'Length (2) /= Exptyp'Length (2) or else 10145 -- T_Typ'Length (3) /= Exptyp'Length (3) or else 10146 -- ... 10147 10148 elsif Is_Constrained (Exptyp) then 10149 declare 10150 Ndims : constant Nat := Number_Dimensions (T_Typ); 10151 10152 L_Index : Node_Id; 10153 R_Index : Node_Id; 10154 L_Low : Node_Id; 10155 L_High : Node_Id; 10156 R_Low : Node_Id; 10157 R_High : Node_Id; 10158 L_Length : Uint; 10159 R_Length : Uint; 10160 Ref_Node : Node_Id; 10161 10162 begin 10163 -- At the library level, we need to ensure that the type of 10164 -- the object is elaborated before the check itself is 10165 -- emitted. This is only done if the object is in the 10166 -- current compilation unit, otherwise the type is frozen 10167 -- and elaborated in its unit. 10168 10169 if Is_Itype (Exptyp) 10170 and then 10171 Ekind (Cunit_Entity (Current_Sem_Unit)) = E_Package 10172 and then 10173 not In_Package_Body (Cunit_Entity (Current_Sem_Unit)) 10174 and then In_Open_Scopes (Scope (Exptyp)) 10175 then 10176 Ref_Node := Make_Itype_Reference (Sloc (Expr)); 10177 Set_Itype (Ref_Node, Exptyp); 10178 Insert_Action (Expr, Ref_Node); 10179 end if; 10180 10181 L_Index := First_Index (T_Typ); 10182 R_Index := First_Index (Exptyp); 10183 10184 for Indx in 1 .. Ndims loop 10185 if not (Nkind (L_Index) = N_Raise_Constraint_Error 10186 or else 10187 Nkind (R_Index) = N_Raise_Constraint_Error) 10188 then 10189 Get_Index_Bounds (L_Index, L_Low, L_High); 10190 Get_Index_Bounds (R_Index, R_Low, R_High); 10191 10192 -- Deal with compile time length check. Note that we 10193 -- skip this in the access case, because the access 10194 -- value may be null, so we cannot know statically. 10195 10196 if not Do_Access 10197 and then Compile_Time_Known_Value (L_Low) 10198 and then Compile_Time_Known_Value (L_High) 10199 and then Compile_Time_Known_Value (R_Low) 10200 and then Compile_Time_Known_Value (R_High) 10201 then 10202 if Expr_Value (L_High) >= Expr_Value (L_Low) then 10203 L_Length := Expr_Value (L_High) - 10204 Expr_Value (L_Low) + 1; 10205 else 10206 L_Length := UI_From_Int (0); 10207 end if; 10208 10209 if Expr_Value (R_High) >= Expr_Value (R_Low) then 10210 R_Length := Expr_Value (R_High) - 10211 Expr_Value (R_Low) + 1; 10212 else 10213 R_Length := UI_From_Int (0); 10214 end if; 10215 10216 if L_Length > R_Length then 10217 Add_Check 10218 (Compile_Time_Constraint_Error 10219 (Wnode, "too few elements for}??", T_Typ, 10220 Extra_Msg => Length_Mismatch_Info_Message 10221 (L_Length, R_Length))); 10222 10223 elsif L_Length < R_Length then 10224 Add_Check 10225 (Compile_Time_Constraint_Error 10226 (Wnode, "too many elements for}??", T_Typ, 10227 Extra_Msg => Length_Mismatch_Info_Message 10228 (L_Length, R_Length))); 10229 end if; 10230 10231 -- The comparison for an individual index subtype 10232 -- is omitted if the corresponding index subtypes 10233 -- statically match, since the result is known to 10234 -- be true. Note that this test is worth while even 10235 -- though we do static evaluation, because non-static 10236 -- subtypes can statically match. 10237 10238 elsif not 10239 Subtypes_Statically_Match 10240 (Etype (L_Index), Etype (R_Index)) 10241 10242 and then not 10243 (Same_Bounds (L_Low, R_Low) 10244 and then Same_Bounds (L_High, R_High)) 10245 then 10246 Evolve_Or_Else 10247 (Cond, Length_E_Cond (Exptyp, T_Typ, Indx)); 10248 end if; 10249 10250 Next (L_Index); 10251 Next (R_Index); 10252 end if; 10253 end loop; 10254 end; 10255 10256 -- Handle cases where we do not get a usable actual subtype that 10257 -- is constrained. This happens for example in the function call 10258 -- and explicit dereference cases. In these cases, we have to get 10259 -- the length or range from the expression itself, making sure we 10260 -- do not evaluate it more than once. 10261 10262 -- Here Expr is the original expression, or more properly the 10263 -- result of applying Duplicate_Expr to the original tree, forcing 10264 -- the result to be a name. 10265 10266 else 10267 declare 10268 Ndims : constant Pos := Number_Dimensions (T_Typ); 10269 10270 begin 10271 -- Build the condition for the explicit dereference case 10272 10273 for Indx in 1 .. Ndims loop 10274 Evolve_Or_Else 10275 (Cond, Length_N_Cond (Expr, T_Typ, Indx)); 10276 end loop; 10277 end; 10278 end if; 10279 end if; 10280 end if; 10281 10282 -- Construct the test and insert into the tree 10283 10284 if Present (Cond) then 10285 if Do_Access then 10286 Cond := Guard_Access (Cond, Loc, Expr); 10287 end if; 10288 10289 Add_Check 10290 (Make_Raise_Constraint_Error (Loc, 10291 Condition => Cond, 10292 Reason => CE_Length_Check_Failed)); 10293 end if; 10294 10295 return Ret_Result; 10296 end Selected_Length_Checks; 10297 10298 --------------------------- 10299 -- Selected_Range_Checks -- 10300 --------------------------- 10301 10302 function Selected_Range_Checks 10303 (Expr : Node_Id; 10304 Target_Typ : Entity_Id; 10305 Source_Typ : Entity_Id; 10306 Warn_Node : Node_Id) return Check_Result 10307 is 10308 Loc : constant Source_Ptr := Sloc (Expr); 10309 S_Typ : Entity_Id; 10310 T_Typ : Entity_Id; 10311 Expr_Actual : Node_Id; 10312 Exptyp : Entity_Id; 10313 Cond : Node_Id := Empty; 10314 Do_Access : Boolean := False; 10315 Wnode : Node_Id := Warn_Node; 10316 Ret_Result : Check_Result := (Empty, Empty); 10317 Num_Checks : Natural := 0; 10318 10319 procedure Add_Check (N : Node_Id); 10320 -- Adds the action given to Ret_Result if N is non-Empty 10321 10322 function Discrete_Range_Cond 10323 (Exp : Node_Id; 10324 Typ : Entity_Id) return Node_Id; 10325 -- Returns expression to compute: 10326 -- Low_Bound (Exp) < Typ'First 10327 -- or else 10328 -- High_Bound (Exp) > Typ'Last 10329 10330 function Discrete_Expr_Cond 10331 (Exp : Node_Id; 10332 Typ : Entity_Id) return Node_Id; 10333 -- Returns expression to compute: 10334 -- Exp < Typ'First 10335 -- or else 10336 -- Exp > Typ'Last 10337 10338 function Get_E_First_Or_Last 10339 (Loc : Source_Ptr; 10340 E : Entity_Id; 10341 Indx : Nat; 10342 Nam : Name_Id) return Node_Id; 10343 -- Returns an attribute reference 10344 -- E'First or E'Last 10345 -- with a source location of Loc. 10346 -- 10347 -- Nam is Name_First or Name_Last, according to which attribute is 10348 -- desired. If Indx is non-zero, it is passed as a literal in the 10349 -- Expressions of the attribute reference (identifying the desired 10350 -- array dimension). 10351 10352 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id; 10353 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id; 10354 -- Returns expression to compute: 10355 -- N'First or N'Last using Duplicate_Subexpr_No_Checks 10356 10357 function Range_E_Cond 10358 (Exptyp : Entity_Id; 10359 Typ : Entity_Id; 10360 Indx : Nat) 10361 return Node_Id; 10362 -- Returns expression to compute: 10363 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last 10364 10365 function Range_Equal_E_Cond 10366 (Exptyp : Entity_Id; 10367 Typ : Entity_Id; 10368 Indx : Nat) return Node_Id; 10369 -- Returns expression to compute: 10370 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last 10371 10372 function Range_N_Cond 10373 (Exp : Node_Id; 10374 Typ : Entity_Id; 10375 Indx : Nat) return Node_Id; 10376 -- Return expression to compute: 10377 -- Exp'First < Typ'First or else Exp'Last > Typ'Last 10378 10379 --------------- 10380 -- Add_Check -- 10381 --------------- 10382 10383 procedure Add_Check (N : Node_Id) is 10384 begin 10385 if Present (N) then 10386 10387 -- For now, ignore attempt to place more than 2 checks ??? 10388 10389 if Num_Checks = 2 then 10390 return; 10391 end if; 10392 10393 pragma Assert (Num_Checks <= 1); 10394 Num_Checks := Num_Checks + 1; 10395 Ret_Result (Num_Checks) := N; 10396 end if; 10397 end Add_Check; 10398 10399 ------------------------- 10400 -- Discrete_Expr_Cond -- 10401 ------------------------- 10402 10403 function Discrete_Expr_Cond 10404 (Exp : Node_Id; 10405 Typ : Entity_Id) return Node_Id 10406 is 10407 begin 10408 return 10409 Make_Or_Else (Loc, 10410 Left_Opnd => 10411 Make_Op_Lt (Loc, 10412 Left_Opnd => 10413 Convert_To (Base_Type (Typ), 10414 Duplicate_Subexpr_No_Checks (Exp)), 10415 Right_Opnd => 10416 Convert_To (Base_Type (Typ), 10417 Get_E_First_Or_Last (Loc, Typ, 0, Name_First))), 10418 10419 Right_Opnd => 10420 Make_Op_Gt (Loc, 10421 Left_Opnd => 10422 Convert_To (Base_Type (Typ), 10423 Duplicate_Subexpr_No_Checks (Exp)), 10424 Right_Opnd => 10425 Convert_To 10426 (Base_Type (Typ), 10427 Get_E_First_Or_Last (Loc, Typ, 0, Name_Last)))); 10428 end Discrete_Expr_Cond; 10429 10430 ------------------------- 10431 -- Discrete_Range_Cond -- 10432 ------------------------- 10433 10434 function Discrete_Range_Cond 10435 (Exp : Node_Id; 10436 Typ : Entity_Id) return Node_Id 10437 is 10438 LB : Node_Id := Low_Bound (Exp); 10439 HB : Node_Id := High_Bound (Exp); 10440 10441 Left_Opnd : Node_Id; 10442 Right_Opnd : Node_Id; 10443 10444 begin 10445 if Nkind (LB) = N_Identifier 10446 and then Ekind (Entity (LB)) = E_Discriminant 10447 then 10448 LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc); 10449 end if; 10450 10451 Left_Opnd := 10452 Make_Op_Lt (Loc, 10453 Left_Opnd => 10454 Convert_To 10455 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)), 10456 10457 Right_Opnd => 10458 Convert_To 10459 (Base_Type (Typ), 10460 Get_E_First_Or_Last (Loc, Typ, 0, Name_First))); 10461 10462 if Nkind (HB) = N_Identifier 10463 and then Ekind (Entity (HB)) = E_Discriminant 10464 then 10465 HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc); 10466 end if; 10467 10468 Right_Opnd := 10469 Make_Op_Gt (Loc, 10470 Left_Opnd => 10471 Convert_To 10472 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (HB)), 10473 10474 Right_Opnd => 10475 Convert_To 10476 (Base_Type (Typ), 10477 Get_E_First_Or_Last (Loc, Typ, 0, Name_Last))); 10478 10479 return Make_Or_Else (Loc, Left_Opnd, Right_Opnd); 10480 end Discrete_Range_Cond; 10481 10482 ------------------------- 10483 -- Get_E_First_Or_Last -- 10484 ------------------------- 10485 10486 function Get_E_First_Or_Last 10487 (Loc : Source_Ptr; 10488 E : Entity_Id; 10489 Indx : Nat; 10490 Nam : Name_Id) return Node_Id 10491 is 10492 Exprs : List_Id; 10493 begin 10494 if Indx > 0 then 10495 Exprs := New_List (Make_Integer_Literal (Loc, UI_From_Int (Indx))); 10496 else 10497 Exprs := No_List; 10498 end if; 10499 10500 return Make_Attribute_Reference (Loc, 10501 Prefix => New_Occurrence_Of (E, Loc), 10502 Attribute_Name => Nam, 10503 Expressions => Exprs); 10504 end Get_E_First_Or_Last; 10505 10506 ----------------- 10507 -- Get_N_First -- 10508 ----------------- 10509 10510 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is 10511 begin 10512 return 10513 Make_Attribute_Reference (Loc, 10514 Attribute_Name => Name_First, 10515 Prefix => 10516 Duplicate_Subexpr_No_Checks (N, Name_Req => True), 10517 Expressions => New_List ( 10518 Make_Integer_Literal (Loc, Indx))); 10519 end Get_N_First; 10520 10521 ---------------- 10522 -- Get_N_Last -- 10523 ---------------- 10524 10525 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is 10526 begin 10527 return 10528 Make_Attribute_Reference (Loc, 10529 Attribute_Name => Name_Last, 10530 Prefix => 10531 Duplicate_Subexpr_No_Checks (N, Name_Req => True), 10532 Expressions => New_List ( 10533 Make_Integer_Literal (Loc, Indx))); 10534 end Get_N_Last; 10535 10536 ------------------ 10537 -- Range_E_Cond -- 10538 ------------------ 10539 10540 function Range_E_Cond 10541 (Exptyp : Entity_Id; 10542 Typ : Entity_Id; 10543 Indx : Nat) return Node_Id 10544 is 10545 begin 10546 return 10547 Make_Or_Else (Loc, 10548 Left_Opnd => 10549 Make_Op_Lt (Loc, 10550 Left_Opnd => 10551 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First), 10552 Right_Opnd => 10553 Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)), 10554 10555 Right_Opnd => 10556 Make_Op_Gt (Loc, 10557 Left_Opnd => 10558 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last), 10559 Right_Opnd => 10560 Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); 10561 end Range_E_Cond; 10562 10563 ------------------------ 10564 -- Range_Equal_E_Cond -- 10565 ------------------------ 10566 10567 function Range_Equal_E_Cond 10568 (Exptyp : Entity_Id; 10569 Typ : Entity_Id; 10570 Indx : Nat) return Node_Id 10571 is 10572 begin 10573 return 10574 Make_Or_Else (Loc, 10575 Left_Opnd => 10576 Make_Op_Ne (Loc, 10577 Left_Opnd => 10578 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First), 10579 Right_Opnd => 10580 Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)), 10581 10582 Right_Opnd => 10583 Make_Op_Ne (Loc, 10584 Left_Opnd => 10585 Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last), 10586 Right_Opnd => 10587 Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); 10588 end Range_Equal_E_Cond; 10589 10590 ------------------ 10591 -- Range_N_Cond -- 10592 ------------------ 10593 10594 function Range_N_Cond 10595 (Exp : Node_Id; 10596 Typ : Entity_Id; 10597 Indx : Nat) return Node_Id 10598 is 10599 begin 10600 return 10601 Make_Or_Else (Loc, 10602 Left_Opnd => 10603 Make_Op_Lt (Loc, 10604 Left_Opnd => 10605 Get_N_First (Exp, Indx), 10606 Right_Opnd => 10607 Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)), 10608 10609 Right_Opnd => 10610 Make_Op_Gt (Loc, 10611 Left_Opnd => 10612 Get_N_Last (Exp, Indx), 10613 Right_Opnd => 10614 Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); 10615 end Range_N_Cond; 10616 10617 -- Start of processing for Selected_Range_Checks 10618 10619 begin 10620 -- Checks will be applied only when generating code. In GNATprove mode, 10621 -- we do not apply the checks, but we still call Selected_Range_Checks 10622 -- outside of generics to possibly issue errors on SPARK code when a 10623 -- run-time error can be detected at compile time. 10624 10625 if Inside_A_Generic or (not GNATprove_Mode and not Expander_Active) then 10626 return Ret_Result; 10627 end if; 10628 10629 if Target_Typ = Any_Type 10630 or else Target_Typ = Any_Composite 10631 or else Raises_Constraint_Error (Expr) 10632 then 10633 return Ret_Result; 10634 end if; 10635 10636 if No (Wnode) then 10637 Wnode := Expr; 10638 end if; 10639 10640 T_Typ := Target_Typ; 10641 10642 if No (Source_Typ) then 10643 S_Typ := Etype (Expr); 10644 else 10645 S_Typ := Source_Typ; 10646 end if; 10647 10648 if S_Typ = Any_Type or else S_Typ = Any_Composite then 10649 return Ret_Result; 10650 end if; 10651 10652 -- The order of evaluating T_Typ before S_Typ seems to be critical 10653 -- because S_Typ can be derived from Etype (Expr), if it's not passed 10654 -- in, and since Node can be an N_Range node, it might be invalid. 10655 -- Should there be an assert check somewhere for taking the Etype of 10656 -- an N_Range node ??? 10657 10658 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then 10659 S_Typ := Designated_Type (S_Typ); 10660 T_Typ := Designated_Type (T_Typ); 10661 Do_Access := True; 10662 10663 -- A simple optimization for the null case 10664 10665 if Known_Null (Expr) then 10666 return Ret_Result; 10667 end if; 10668 end if; 10669 10670 -- For an N_Range Node, check for a null range and then if not 10671 -- null generate a range check action. 10672 10673 if Nkind (Expr) = N_Range then 10674 10675 -- There's no point in checking a range against itself 10676 10677 if Expr = Scalar_Range (T_Typ) then 10678 return Ret_Result; 10679 end if; 10680 10681 declare 10682 T_LB : constant Node_Id := Type_Low_Bound (T_Typ); 10683 T_HB : constant Node_Id := Type_High_Bound (T_Typ); 10684 Known_T_LB : constant Boolean := Compile_Time_Known_Value (T_LB); 10685 Known_T_HB : constant Boolean := Compile_Time_Known_Value (T_HB); 10686 10687 LB : Node_Id := Low_Bound (Expr); 10688 HB : Node_Id := High_Bound (Expr); 10689 Known_LB : Boolean := False; 10690 Known_HB : Boolean := False; 10691 10692 Null_Range : Boolean; 10693 Out_Of_Range_L : Boolean; 10694 Out_Of_Range_H : Boolean; 10695 10696 begin 10697 -- Compute what is known at compile time 10698 10699 if Known_T_LB and Known_T_HB then 10700 if Compile_Time_Known_Value (LB) then 10701 Known_LB := True; 10702 10703 -- There's no point in checking that a bound is within its 10704 -- own range so pretend that it is known in this case. First 10705 -- deal with low bound. 10706 10707 elsif Ekind (Etype (LB)) = E_Signed_Integer_Subtype 10708 and then Scalar_Range (Etype (LB)) = Scalar_Range (T_Typ) 10709 then 10710 LB := T_LB; 10711 Known_LB := True; 10712 end if; 10713 10714 -- Likewise for the high bound 10715 10716 if Compile_Time_Known_Value (HB) then 10717 Known_HB := True; 10718 10719 elsif Ekind (Etype (HB)) = E_Signed_Integer_Subtype 10720 and then Scalar_Range (Etype (HB)) = Scalar_Range (T_Typ) 10721 then 10722 HB := T_HB; 10723 Known_HB := True; 10724 end if; 10725 end if; 10726 10727 -- Check for case where everything is static and we can do the 10728 -- check at compile time. This is skipped if we have an access 10729 -- type, since the access value may be null. 10730 10731 -- ??? This code can be improved since you only need to know that 10732 -- the two respective bounds (LB & T_LB or HB & T_HB) are known at 10733 -- compile time to emit pertinent messages. 10734 10735 if Known_T_LB and Known_T_HB and Known_LB and Known_HB 10736 and not Do_Access 10737 then 10738 -- Floating-point case 10739 10740 if Is_Floating_Point_Type (S_Typ) then 10741 Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB); 10742 Out_Of_Range_L := 10743 (Expr_Value_R (LB) < Expr_Value_R (T_LB)) 10744 or else 10745 (Expr_Value_R (LB) > Expr_Value_R (T_HB)); 10746 10747 Out_Of_Range_H := 10748 (Expr_Value_R (HB) > Expr_Value_R (T_HB)) 10749 or else 10750 (Expr_Value_R (HB) < Expr_Value_R (T_LB)); 10751 10752 -- Fixed or discrete type case 10753 10754 else 10755 Null_Range := Expr_Value (HB) < Expr_Value (LB); 10756 Out_Of_Range_L := 10757 (Expr_Value (LB) < Expr_Value (T_LB)) 10758 or else 10759 (Expr_Value (LB) > Expr_Value (T_HB)); 10760 10761 Out_Of_Range_H := 10762 (Expr_Value (HB) > Expr_Value (T_HB)) 10763 or else 10764 (Expr_Value (HB) < Expr_Value (T_LB)); 10765 end if; 10766 10767 if not Null_Range then 10768 if Out_Of_Range_L then 10769 if No (Warn_Node) then 10770 Add_Check 10771 (Compile_Time_Constraint_Error 10772 (Low_Bound (Expr), 10773 "static value out of range of}??", T_Typ)); 10774 10775 else 10776 Add_Check 10777 (Compile_Time_Constraint_Error 10778 (Wnode, 10779 "static range out of bounds of}??", T_Typ)); 10780 end if; 10781 end if; 10782 10783 if Out_Of_Range_H then 10784 if No (Warn_Node) then 10785 Add_Check 10786 (Compile_Time_Constraint_Error 10787 (High_Bound (Expr), 10788 "static value out of range of}??", T_Typ)); 10789 10790 else 10791 Add_Check 10792 (Compile_Time_Constraint_Error 10793 (Wnode, 10794 "static range out of bounds of}??", T_Typ)); 10795 end if; 10796 end if; 10797 end if; 10798 10799 else 10800 declare 10801 LB : Node_Id := Low_Bound (Expr); 10802 HB : Node_Id := High_Bound (Expr); 10803 10804 begin 10805 -- If either bound is a discriminant and we are within the 10806 -- record declaration, it is a use of the discriminant in a 10807 -- constraint of a component, and nothing can be checked 10808 -- here. The check will be emitted within the init proc. 10809 -- Before then, the discriminal has no real meaning. 10810 -- Similarly, if the entity is a discriminal, there is no 10811 -- check to perform yet. 10812 10813 -- The same holds within a discriminated synchronized type, 10814 -- where the discriminant may constrain a component or an 10815 -- entry family. 10816 10817 if Nkind (LB) = N_Identifier 10818 and then Denotes_Discriminant (LB, True) 10819 then 10820 if Current_Scope = Scope (Entity (LB)) 10821 or else Is_Concurrent_Type (Current_Scope) 10822 or else Ekind (Entity (LB)) /= E_Discriminant 10823 then 10824 return Ret_Result; 10825 else 10826 LB := 10827 New_Occurrence_Of (Discriminal (Entity (LB)), Loc); 10828 end if; 10829 end if; 10830 10831 if Nkind (HB) = N_Identifier 10832 and then Denotes_Discriminant (HB, True) 10833 then 10834 if Current_Scope = Scope (Entity (HB)) 10835 or else Is_Concurrent_Type (Current_Scope) 10836 or else Ekind (Entity (HB)) /= E_Discriminant 10837 then 10838 return Ret_Result; 10839 else 10840 HB := 10841 New_Occurrence_Of (Discriminal (Entity (HB)), Loc); 10842 end if; 10843 end if; 10844 10845 Cond := Discrete_Range_Cond (Expr, T_Typ); 10846 Set_Paren_Count (Cond, 1); 10847 10848 Cond := 10849 Make_And_Then (Loc, 10850 Left_Opnd => 10851 Make_Op_Ge (Loc, 10852 Left_Opnd => 10853 Convert_To (Base_Type (Etype (HB)), 10854 Duplicate_Subexpr_No_Checks (HB)), 10855 Right_Opnd => 10856 Convert_To (Base_Type (Etype (LB)), 10857 Duplicate_Subexpr_No_Checks (LB))), 10858 Right_Opnd => Cond); 10859 end; 10860 end if; 10861 end; 10862 10863 elsif Is_Scalar_Type (S_Typ) then 10864 10865 -- This somewhat duplicates what Apply_Scalar_Range_Check does, 10866 -- except the above simply sets a flag in the node and lets 10867 -- gigi generate the check base on the Etype of the expression. 10868 -- Sometimes, however we want to do a dynamic check against an 10869 -- arbitrary target type, so we do that here. 10870 10871 if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then 10872 Cond := Discrete_Expr_Cond (Expr, T_Typ); 10873 10874 -- For literals, we can tell if the constraint error will be 10875 -- raised at compile time, so we never need a dynamic check, but 10876 -- if the exception will be raised, then post the usual warning, 10877 -- and replace the literal with a raise constraint error 10878 -- expression. As usual, skip this for access types 10879 10880 elsif Compile_Time_Known_Value (Expr) and then not Do_Access then 10881 declare 10882 LB : constant Node_Id := Type_Low_Bound (T_Typ); 10883 UB : constant Node_Id := Type_High_Bound (T_Typ); 10884 10885 Out_Of_Range : Boolean; 10886 Static_Bounds : constant Boolean := 10887 Compile_Time_Known_Value (LB) 10888 and Compile_Time_Known_Value (UB); 10889 10890 begin 10891 -- Following range tests should use Sem_Eval routine ??? 10892 10893 if Static_Bounds then 10894 if Is_Floating_Point_Type (S_Typ) then 10895 Out_Of_Range := 10896 (Expr_Value_R (Expr) < Expr_Value_R (LB)) 10897 or else 10898 (Expr_Value_R (Expr) > Expr_Value_R (UB)); 10899 10900 -- Fixed or discrete type 10901 10902 else 10903 Out_Of_Range := 10904 Expr_Value (Expr) < Expr_Value (LB) 10905 or else 10906 Expr_Value (Expr) > Expr_Value (UB); 10907 end if; 10908 10909 -- Bounds of the type are static and the literal is out of 10910 -- range so output a warning message. 10911 10912 if Out_Of_Range then 10913 if No (Warn_Node) then 10914 Add_Check 10915 (Compile_Time_Constraint_Error 10916 (Expr, 10917 "static value out of range of}??", T_Typ)); 10918 10919 else 10920 Add_Check 10921 (Compile_Time_Constraint_Error 10922 (Wnode, 10923 "static value out of range of}??", T_Typ)); 10924 end if; 10925 end if; 10926 10927 else 10928 Cond := Discrete_Expr_Cond (Expr, T_Typ); 10929 end if; 10930 end; 10931 10932 -- Here for the case of a non-static expression, we need a runtime 10933 -- check unless the source type range is guaranteed to be in the 10934 -- range of the target type. 10935 10936 else 10937 if not In_Subrange_Of (S_Typ, T_Typ) then 10938 Cond := Discrete_Expr_Cond (Expr, T_Typ); 10939 end if; 10940 end if; 10941 end if; 10942 10943 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then 10944 if Is_Constrained (T_Typ) then 10945 10946 Expr_Actual := Get_Referenced_Object (Expr); 10947 Exptyp := Get_Actual_Subtype (Expr_Actual); 10948 10949 if Is_Access_Type (Exptyp) then 10950 Exptyp := Designated_Type (Exptyp); 10951 end if; 10952 10953 -- String_Literal case. This needs to be handled specially be- 10954 -- cause no index types are available for string literals. The 10955 -- condition is simply: 10956 10957 -- T_Typ'Length = string-literal-length 10958 10959 if Nkind (Expr_Actual) = N_String_Literal then 10960 null; 10961 10962 -- General array case. Here we have a usable actual subtype for 10963 -- the expression, and the condition is built from the two types 10964 10965 -- T_Typ'First < Exptyp'First or else 10966 -- T_Typ'Last > Exptyp'Last or else 10967 -- T_Typ'First(1) < Exptyp'First(1) or else 10968 -- T_Typ'Last(1) > Exptyp'Last(1) or else 10969 -- ... 10970 10971 elsif Is_Constrained (Exptyp) then 10972 declare 10973 Ndims : constant Pos := Number_Dimensions (T_Typ); 10974 10975 L_Index : Node_Id; 10976 R_Index : Node_Id; 10977 10978 begin 10979 L_Index := First_Index (T_Typ); 10980 R_Index := First_Index (Exptyp); 10981 10982 for Indx in 1 .. Ndims loop 10983 if not (Nkind (L_Index) = N_Raise_Constraint_Error 10984 or else 10985 Nkind (R_Index) = N_Raise_Constraint_Error) 10986 then 10987 -- Deal with compile time length check. Note that we 10988 -- skip this in the access case, because the access 10989 -- value may be null, so we cannot know statically. 10990 10991 if not 10992 Subtypes_Statically_Match 10993 (Etype (L_Index), Etype (R_Index)) 10994 then 10995 -- If the target type is constrained then we 10996 -- have to check for exact equality of bounds 10997 -- (required for qualified expressions). 10998 10999 if Is_Constrained (T_Typ) then 11000 Evolve_Or_Else 11001 (Cond, 11002 Range_Equal_E_Cond (Exptyp, T_Typ, Indx)); 11003 else 11004 Evolve_Or_Else 11005 (Cond, Range_E_Cond (Exptyp, T_Typ, Indx)); 11006 end if; 11007 end if; 11008 11009 Next (L_Index); 11010 Next (R_Index); 11011 end if; 11012 end loop; 11013 end; 11014 11015 -- Handle cases where we do not get a usable actual subtype that 11016 -- is constrained. This happens for example in the function call 11017 -- and explicit dereference cases. In these cases, we have to get 11018 -- the length or range from the expression itself, making sure we 11019 -- do not evaluate it more than once. 11020 11021 -- Here Expr is the original expression, or more properly the 11022 -- result of applying Duplicate_Expr to the original tree, 11023 -- forcing the result to be a name. 11024 11025 else 11026 declare 11027 Ndims : constant Pos := Number_Dimensions (T_Typ); 11028 11029 begin 11030 -- Build the condition for the explicit dereference case 11031 11032 for Indx in 1 .. Ndims loop 11033 Evolve_Or_Else 11034 (Cond, Range_N_Cond (Expr, T_Typ, Indx)); 11035 end loop; 11036 end; 11037 end if; 11038 11039 else 11040 -- For a conversion to an unconstrained array type, generate an 11041 -- Action to check that the bounds of the source value are within 11042 -- the constraints imposed by the target type (RM 4.6(38)). No 11043 -- check is needed for a conversion to an access to unconstrained 11044 -- array type, as 4.6(24.15/2) requires the designated subtypes 11045 -- of the two access types to statically match. 11046 11047 if Nkind (Parent (Expr)) = N_Type_Conversion 11048 and then not Do_Access 11049 then 11050 declare 11051 Opnd_Index : Node_Id; 11052 Targ_Index : Node_Id; 11053 Opnd_Range : Node_Id; 11054 11055 begin 11056 Opnd_Index := First_Index (Get_Actual_Subtype (Expr)); 11057 Targ_Index := First_Index (T_Typ); 11058 while Present (Opnd_Index) loop 11059 11060 -- If the index is a range, use its bounds. If it is an 11061 -- entity (as will be the case if it is a named subtype 11062 -- or an itype created for a slice) retrieve its range. 11063 11064 if Is_Entity_Name (Opnd_Index) 11065 and then Is_Type (Entity (Opnd_Index)) 11066 then 11067 Opnd_Range := Scalar_Range (Entity (Opnd_Index)); 11068 else 11069 Opnd_Range := Opnd_Index; 11070 end if; 11071 11072 if Nkind (Opnd_Range) = N_Range then 11073 if Is_In_Range 11074 (Low_Bound (Opnd_Range), Etype (Targ_Index), 11075 Assume_Valid => True) 11076 and then 11077 Is_In_Range 11078 (High_Bound (Opnd_Range), Etype (Targ_Index), 11079 Assume_Valid => True) 11080 then 11081 null; 11082 11083 -- If null range, no check needed 11084 11085 elsif 11086 Compile_Time_Known_Value (High_Bound (Opnd_Range)) 11087 and then 11088 Compile_Time_Known_Value (Low_Bound (Opnd_Range)) 11089 and then 11090 Expr_Value (High_Bound (Opnd_Range)) < 11091 Expr_Value (Low_Bound (Opnd_Range)) 11092 then 11093 null; 11094 11095 elsif Is_Out_Of_Range 11096 (Low_Bound (Opnd_Range), Etype (Targ_Index), 11097 Assume_Valid => True) 11098 or else 11099 Is_Out_Of_Range 11100 (High_Bound (Opnd_Range), Etype (Targ_Index), 11101 Assume_Valid => True) 11102 then 11103 Add_Check 11104 (Compile_Time_Constraint_Error 11105 (Wnode, "value out of range of}??", T_Typ)); 11106 11107 else 11108 Evolve_Or_Else 11109 (Cond, 11110 Discrete_Range_Cond 11111 (Opnd_Range, Etype (Targ_Index))); 11112 end if; 11113 end if; 11114 11115 Next_Index (Opnd_Index); 11116 Next_Index (Targ_Index); 11117 end loop; 11118 end; 11119 end if; 11120 end if; 11121 end if; 11122 11123 -- Construct the test and insert into the tree 11124 11125 if Present (Cond) then 11126 if Do_Access then 11127 Cond := Guard_Access (Cond, Loc, Expr); 11128 end if; 11129 11130 Add_Check 11131 (Make_Raise_Constraint_Error (Loc, 11132 Condition => Cond, 11133 Reason => CE_Range_Check_Failed)); 11134 end if; 11135 11136 return Ret_Result; 11137 end Selected_Range_Checks; 11138 11139 ------------------------------- 11140 -- Storage_Checks_Suppressed -- 11141 ------------------------------- 11142 11143 function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is 11144 begin 11145 if Present (E) and then Checks_May_Be_Suppressed (E) then 11146 return Is_Check_Suppressed (E, Storage_Check); 11147 else 11148 return Scope_Suppress.Suppress (Storage_Check); 11149 end if; 11150 end Storage_Checks_Suppressed; 11151 11152 --------------------------- 11153 -- Tag_Checks_Suppressed -- 11154 --------------------------- 11155 11156 function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is 11157 begin 11158 if Present (E) 11159 and then Checks_May_Be_Suppressed (E) 11160 then 11161 return Is_Check_Suppressed (E, Tag_Check); 11162 else 11163 return Scope_Suppress.Suppress (Tag_Check); 11164 end if; 11165 end Tag_Checks_Suppressed; 11166 11167 --------------------------------------- 11168 -- Validate_Alignment_Check_Warnings -- 11169 --------------------------------------- 11170 11171 procedure Validate_Alignment_Check_Warnings is 11172 begin 11173 for J in Alignment_Warnings.First .. Alignment_Warnings.Last loop 11174 declare 11175 AWR : Alignment_Warnings_Record 11176 renames Alignment_Warnings.Table (J); 11177 begin 11178 if Known_Alignment (AWR.E) 11179 and then ((AWR.A /= No_Uint 11180 and then AWR.A mod Alignment (AWR.E) = 0) 11181 or else (Present (AWR.P) 11182 and then Has_Compatible_Alignment 11183 (AWR.E, AWR.P, True) = 11184 Known_Compatible)) 11185 then 11186 Delete_Warning_And_Continuations (AWR.W); 11187 end if; 11188 end; 11189 end loop; 11190 end Validate_Alignment_Check_Warnings; 11191 11192 -------------------------- 11193 -- Validity_Check_Range -- 11194 -------------------------- 11195 11196 procedure Validity_Check_Range 11197 (N : Node_Id; 11198 Related_Id : Entity_Id := Empty) is 11199 begin 11200 if Validity_Checks_On and Validity_Check_Operands then 11201 if Nkind (N) = N_Range then 11202 Ensure_Valid 11203 (Expr => Low_Bound (N), 11204 Related_Id => Related_Id, 11205 Is_Low_Bound => True); 11206 11207 Ensure_Valid 11208 (Expr => High_Bound (N), 11209 Related_Id => Related_Id, 11210 Is_High_Bound => True); 11211 end if; 11212 end if; 11213 end Validity_Check_Range; 11214 11215end Checks; 11216