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