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