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