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