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