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