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