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