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-2003 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with Atree; use Atree; 28with Debug; use Debug; 29with Einfo; use Einfo; 30with Errout; use Errout; 31with Exp_Ch2; use Exp_Ch2; 32with Exp_Util; use Exp_Util; 33with Elists; use Elists; 34with Freeze; use Freeze; 35with Lib; use Lib; 36with Nlists; use Nlists; 37with Nmake; use Nmake; 38with Opt; use Opt; 39with Output; use Output; 40with Restrict; use Restrict; 41with Rtsfind; use Rtsfind; 42with Sem; use Sem; 43with Sem_Eval; use Sem_Eval; 44with Sem_Ch8; use Sem_Ch8; 45with Sem_Res; use Sem_Res; 46with Sem_Util; use Sem_Util; 47with Sem_Warn; use Sem_Warn; 48with Sinfo; use Sinfo; 49with Sinput; use Sinput; 50with Snames; use Snames; 51with Sprint; use Sprint; 52with Stand; use Stand; 53with Targparm; use Targparm; 54with Tbuild; use Tbuild; 55with Ttypes; use Ttypes; 56with Urealp; use Urealp; 57with Validsw; use Validsw; 58 59package body Checks is 60 61 -- General note: many of these routines are concerned with generating 62 -- checking code to make sure that constraint error is raised at runtime. 63 -- Clearly this code is only needed if the expander is active, since 64 -- otherwise we will not be generating code or going into the runtime 65 -- execution anyway. 66 67 -- We therefore disconnect most of these checks if the expander is 68 -- inactive. This has the additional benefit that we do not need to 69 -- worry about the tree being messed up by previous errors (since errors 70 -- turn off expansion anyway). 71 72 -- There are a few exceptions to the above rule. For instance routines 73 -- such as Apply_Scalar_Range_Check that do not insert any code can be 74 -- safely called even when the Expander is inactive (but Errors_Detected 75 -- is 0). The benefit of executing this code when expansion is off, is 76 -- the ability to emit constraint error warning for static expressions 77 -- even when we are not generating code. 78 79 ------------------------------------- 80 -- Suppression of Redundant Checks -- 81 ------------------------------------- 82 83 -- This unit implements a limited circuit for removal of redundant 84 -- checks. The processing is based on a tracing of simple sequential 85 -- flow. For any sequence of statements, we save expressions that are 86 -- marked to be checked, and then if the same expression appears later 87 -- with the same check, then under certain circumstances, the second 88 -- check can be suppressed. 89 90 -- Basically, we can suppress the check if we know for certain that 91 -- the previous expression has been elaborated (together with its 92 -- check), and we know that the exception frame is the same, and that 93 -- nothing has happened to change the result of the exception. 94 95 -- Let us examine each of these three conditions in turn to describe 96 -- how we ensure that this condition is met. 97 98 -- First, we need to know for certain that the previous expression has 99 -- been executed. This is done principly by the mechanism of calling 100 -- Conditional_Statements_Begin at the start of any statement sequence 101 -- and Conditional_Statements_End at the end. The End call causes all 102 -- checks remembered since the Begin call to be discarded. This does 103 -- miss a few cases, notably the case of a nested BEGIN-END block with 104 -- no exception handlers. But the important thing is to be conservative. 105 -- The other protection is that all checks are discarded if a label 106 -- is encountered, since then the assumption of sequential execution 107 -- is violated, and we don't know enough about the flow. 108 109 -- Second, we need to know that the exception frame is the same. We 110 -- do this by killing all remembered checks when we enter a new frame. 111 -- Again, that's over-conservative, but generally the cases we can help 112 -- with are pretty local anyway (like the body of a loop for example). 113 114 -- Third, we must be sure to forget any checks which are no longer valid. 115 -- This is done by two mechanisms, first the Kill_Checks_Variable call is 116 -- used to note any changes to local variables. We only attempt to deal 117 -- with checks involving local variables, so we do not need to worry 118 -- about global variables. Second, a call to any non-global procedure 119 -- causes us to abandon all stored checks, since such a all may affect 120 -- the values of any local variables. 121 122 -- The following define the data structures used to deal with remembering 123 -- checks so that redundant checks can be eliminated as described above. 124 125 -- Right now, the only expressions that we deal with are of the form of 126 -- simple local objects (either declared locally, or IN parameters) or 127 -- such objects plus/minus a compile time known constant. We can do 128 -- more later on if it seems worthwhile, but this catches many simple 129 -- cases in practice. 130 131 -- The following record type reflects a single saved check. An entry 132 -- is made in the stack of saved checks if and only if the expression 133 -- has been elaborated with the indicated checks. 134 135 type Saved_Check is record 136 Killed : Boolean; 137 -- Set True if entry is killed by Kill_Checks 138 139 Entity : Entity_Id; 140 -- The entity involved in the expression that is checked 141 142 Offset : Uint; 143 -- A compile time value indicating the result of adding or 144 -- subtracting a compile time value. This value is to be 145 -- added to the value of the Entity. A value of zero is 146 -- used for the case of a simple entity reference. 147 148 Check_Type : Character; 149 -- This is set to 'R' for a range check (in which case Target_Type 150 -- is set to the target type for the range check) or to 'O' for an 151 -- overflow check (in which case Target_Type is set to Empty). 152 153 Target_Type : Entity_Id; 154 -- Used only if Do_Range_Check is set. Records the target type for 155 -- the check. We need this, because a check is a duplicate only if 156 -- it has a the same target type (or more accurately one with a 157 -- range that is smaller or equal to the stored target type of a 158 -- saved check). 159 end record; 160 161 -- The following table keeps track of saved checks. Rather than use an 162 -- extensible table. We just use a table of fixed size, and we discard 163 -- any saved checks that do not fit. That's very unlikely to happen and 164 -- this is only an optimization in any case. 165 166 Saved_Checks : array (Int range 1 .. 200) of Saved_Check; 167 -- Array of saved checks 168 169 Num_Saved_Checks : Nat := 0; 170 -- Number of saved checks 171 172 -- The following stack keeps track of statement ranges. It is treated 173 -- as a stack. When Conditional_Statements_Begin is called, an entry 174 -- is pushed onto this stack containing the value of Num_Saved_Checks 175 -- at the time of the call. Then when Conditional_Statements_End is 176 -- called, this value is popped off and used to reset Num_Saved_Checks. 177 178 -- Note: again, this is a fixed length stack with a size that should 179 -- always be fine. If the value of the stack pointer goes above the 180 -- limit, then we just forget all saved checks. 181 182 Saved_Checks_Stack : array (Int range 1 .. 100) of Nat; 183 Saved_Checks_TOS : Nat := 0; 184 185 ----------------------- 186 -- Local Subprograms -- 187 ----------------------- 188 189 procedure Apply_Selected_Length_Checks 190 (Ck_Node : Node_Id; 191 Target_Typ : Entity_Id; 192 Source_Typ : Entity_Id; 193 Do_Static : Boolean); 194 -- This is the subprogram that does all the work for Apply_Length_Check 195 -- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as 196 -- described for the above routines. The Do_Static flag indicates that 197 -- only a static check is to be done. 198 199 procedure Apply_Selected_Range_Checks 200 (Ck_Node : Node_Id; 201 Target_Typ : Entity_Id; 202 Source_Typ : Entity_Id; 203 Do_Static : Boolean); 204 -- This is the subprogram that does all the work for Apply_Range_Check. 205 -- Expr, Target_Typ and Source_Typ are as described for the above 206 -- routine. The Do_Static flag indicates that only a static check is 207 -- to be done. 208 209 procedure Find_Check 210 (Expr : Node_Id; 211 Check_Type : Character; 212 Target_Type : Entity_Id; 213 Entry_OK : out Boolean; 214 Check_Num : out Nat; 215 Ent : out Entity_Id; 216 Ofs : out Uint); 217 -- This routine is used by Enable_Range_Check and Enable_Overflow_Check 218 -- to see if a check is of the form for optimization, and if so, to see 219 -- if it has already been performed. Expr is the expression to check, 220 -- and Check_Type is 'R' for a range check, 'O' for an overflow check. 221 -- Target_Type is the target type for a range check, and Empty for an 222 -- overflow check. If the entry is not of the form for optimization, 223 -- then Entry_OK is set to False, and the remaining out parameters 224 -- are undefined. If the entry is OK, then Ent/Ofs are set to the 225 -- entity and offset from the expression. Check_Num is the number of 226 -- a matching saved entry in Saved_Checks, or zero if no such entry 227 -- is located. 228 229 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id; 230 -- If a discriminal is used in constraining a prival, Return reference 231 -- to the discriminal of the protected body (which renames the parameter 232 -- of the enclosing protected operation). This clumsy transformation is 233 -- needed because privals are created too late and their actual subtypes 234 -- are not available when analysing the bodies of the protected operations. 235 -- To be cleaned up??? 236 237 function Guard_Access 238 (Cond : Node_Id; 239 Loc : Source_Ptr; 240 Ck_Node : Node_Id) 241 return Node_Id; 242 -- In the access type case, guard the test with a test to ensure 243 -- that the access value is non-null, since the checks do not 244 -- not apply to null access values. 245 246 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr); 247 -- Called by Apply_{Length,Range}_Checks to rewrite the tree with the 248 -- Constraint_Error node. 249 250 function Selected_Length_Checks 251 (Ck_Node : Node_Id; 252 Target_Typ : Entity_Id; 253 Source_Typ : Entity_Id; 254 Warn_Node : Node_Id) 255 return Check_Result; 256 -- Like Apply_Selected_Length_Checks, except it doesn't modify 257 -- anything, just returns a list of nodes as described in the spec of 258 -- this package for the Range_Check function. 259 260 function Selected_Range_Checks 261 (Ck_Node : Node_Id; 262 Target_Typ : Entity_Id; 263 Source_Typ : Entity_Id; 264 Warn_Node : Node_Id) 265 return Check_Result; 266 -- Like Apply_Selected_Range_Checks, except it doesn't modify anything, 267 -- just returns a list of nodes as described in the spec of this package 268 -- for the Range_Check function. 269 270 ------------------------------ 271 -- Access_Checks_Suppressed -- 272 ------------------------------ 273 274 function Access_Checks_Suppressed (E : Entity_Id) return Boolean is 275 begin 276 if Present (E) and then Checks_May_Be_Suppressed (E) then 277 return Is_Check_Suppressed (E, Access_Check); 278 else 279 return Scope_Suppress (Access_Check); 280 end if; 281 end Access_Checks_Suppressed; 282 283 ------------------------------------- 284 -- Accessibility_Checks_Suppressed -- 285 ------------------------------------- 286 287 function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is 288 begin 289 if Present (E) and then Checks_May_Be_Suppressed (E) then 290 return Is_Check_Suppressed (E, Accessibility_Check); 291 else 292 return Scope_Suppress (Accessibility_Check); 293 end if; 294 end Accessibility_Checks_Suppressed; 295 296 ------------------------- 297 -- Append_Range_Checks -- 298 ------------------------- 299 300 procedure Append_Range_Checks 301 (Checks : Check_Result; 302 Stmts : List_Id; 303 Suppress_Typ : Entity_Id; 304 Static_Sloc : Source_Ptr; 305 Flag_Node : Node_Id) 306 is 307 Internal_Flag_Node : constant Node_Id := Flag_Node; 308 Internal_Static_Sloc : constant Source_Ptr := Static_Sloc; 309 310 Checks_On : constant Boolean := 311 (not Index_Checks_Suppressed (Suppress_Typ)) 312 or else 313 (not Range_Checks_Suppressed (Suppress_Typ)); 314 315 begin 316 -- For now we just return if Checks_On is false, however this should 317 -- be enhanced to check for an always True value in the condition 318 -- and to generate a compilation warning??? 319 320 if not Checks_On then 321 return; 322 end if; 323 324 for J in 1 .. 2 loop 325 exit when No (Checks (J)); 326 327 if Nkind (Checks (J)) = N_Raise_Constraint_Error 328 and then Present (Condition (Checks (J))) 329 then 330 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then 331 Append_To (Stmts, Checks (J)); 332 Set_Has_Dynamic_Range_Check (Internal_Flag_Node); 333 end if; 334 335 else 336 Append_To 337 (Stmts, 338 Make_Raise_Constraint_Error (Internal_Static_Sloc, 339 Reason => CE_Range_Check_Failed)); 340 end if; 341 end loop; 342 end Append_Range_Checks; 343 344 ------------------------ 345 -- Apply_Access_Check -- 346 ------------------------ 347 348 procedure Apply_Access_Check (N : Node_Id) is 349 P : constant Node_Id := Prefix (N); 350 351 begin 352 if Inside_A_Generic then 353 return; 354 end if; 355 356 if Is_Entity_Name (P) then 357 Check_Unset_Reference (P); 358 end if; 359 360 -- Don't need access check if prefix is known to be non-null 361 362 if Known_Non_Null (P) then 363 return; 364 365 -- Don't need access checks if they are suppressed on the type 366 367 elsif Access_Checks_Suppressed (Etype (P)) then 368 return; 369 end if; 370 371 -- Case where P is an entity name 372 373 if Is_Entity_Name (P) then 374 declare 375 Ent : constant Entity_Id := Entity (P); 376 377 begin 378 if Access_Checks_Suppressed (Ent) then 379 return; 380 end if; 381 382 -- Otherwise we are going to generate an access check, and 383 -- are we have done it, the entity will now be known non null 384 -- But we have to check for safe sequential semantics here! 385 386 if Safe_To_Capture_Value (N, Ent) then 387 Set_Is_Known_Non_Null (Ent); 388 end if; 389 end; 390 end if; 391 392 -- Access check is required 393 394 declare 395 Loc : constant Source_Ptr := Sloc (N); 396 397 begin 398 Insert_Action (N, 399 Make_Raise_Constraint_Error (Sloc (N), 400 Condition => 401 Make_Op_Eq (Loc, 402 Left_Opnd => Duplicate_Subexpr_Move_Checks (P), 403 Right_Opnd => 404 Make_Null (Loc)), 405 Reason => CE_Access_Check_Failed)); 406 end; 407 end Apply_Access_Check; 408 409 ------------------------------- 410 -- Apply_Accessibility_Check -- 411 ------------------------------- 412 413 procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id) is 414 Loc : constant Source_Ptr := Sloc (N); 415 Param_Ent : constant Entity_Id := Param_Entity (N); 416 Param_Level : Node_Id; 417 Type_Level : Node_Id; 418 419 begin 420 if Inside_A_Generic then 421 return; 422 423 -- Only apply the run-time check if the access parameter 424 -- has an associated extra access level parameter and 425 -- when the level of the type is less deep than the level 426 -- of the access parameter. 427 428 elsif Present (Param_Ent) 429 and then Present (Extra_Accessibility (Param_Ent)) 430 and then UI_Gt (Object_Access_Level (N), 431 Type_Access_Level (Typ)) 432 and then not Accessibility_Checks_Suppressed (Param_Ent) 433 and then not Accessibility_Checks_Suppressed (Typ) 434 then 435 Param_Level := 436 New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc); 437 438 Type_Level := 439 Make_Integer_Literal (Loc, Type_Access_Level (Typ)); 440 441 -- Raise Program_Error if the accessibility level of the 442 -- the access parameter is deeper than the level of the 443 -- target access type. 444 445 Insert_Action (N, 446 Make_Raise_Program_Error (Loc, 447 Condition => 448 Make_Op_Gt (Loc, 449 Left_Opnd => Param_Level, 450 Right_Opnd => Type_Level), 451 Reason => PE_Accessibility_Check_Failed)); 452 453 Analyze_And_Resolve (N); 454 end if; 455 end Apply_Accessibility_Check; 456 457 --------------------------- 458 -- Apply_Alignment_Check -- 459 --------------------------- 460 461 procedure Apply_Alignment_Check (E : Entity_Id; N : Node_Id) is 462 AC : constant Node_Id := Address_Clause (E); 463 Expr : Node_Id; 464 Loc : Source_Ptr; 465 466 Alignment_Required : constant Boolean := Maximum_Alignment > 1; 467 -- Constant to show whether target requires alignment checks 468 469 begin 470 -- See if check needed. Note that we never need a check if the 471 -- maximum alignment is one, since the check will always succeed 472 473 if No (AC) 474 or else not Check_Address_Alignment (AC) 475 or else not Alignment_Required 476 then 477 return; 478 end if; 479 480 Loc := Sloc (AC); 481 Expr := Expression (AC); 482 483 if Nkind (Expr) = N_Unchecked_Type_Conversion then 484 Expr := Expression (Expr); 485 486 elsif Nkind (Expr) = N_Function_Call 487 and then Is_RTE (Entity (Name (Expr)), RE_To_Address) 488 then 489 Expr := First (Parameter_Associations (Expr)); 490 491 if Nkind (Expr) = N_Parameter_Association then 492 Expr := Explicit_Actual_Parameter (Expr); 493 end if; 494 end if; 495 496 -- Here Expr is the address value. See if we know that the 497 -- value is unacceptable at compile time. 498 499 if Compile_Time_Known_Value (Expr) 500 and then Known_Alignment (E) 501 then 502 if Expr_Value (Expr) mod Alignment (E) /= 0 then 503 Insert_Action (N, 504 Make_Raise_Program_Error (Loc, 505 Reason => PE_Misaligned_Address_Value)); 506 Error_Msg_NE 507 ("?specified address for& not " & 508 "consistent with alignment", Expr, E); 509 end if; 510 511 -- Here we do not know if the value is acceptable, generate 512 -- code to raise PE if alignment is inappropriate. 513 514 else 515 -- Skip generation of this code if we don't want elab code 516 517 if not Restrictions (No_Elaboration_Code) then 518 Insert_After_And_Analyze (N, 519 Make_Raise_Program_Error (Loc, 520 Condition => 521 Make_Op_Ne (Loc, 522 Left_Opnd => 523 Make_Op_Mod (Loc, 524 Left_Opnd => 525 Unchecked_Convert_To 526 (RTE (RE_Integer_Address), 527 Duplicate_Subexpr_No_Checks (Expr)), 528 Right_Opnd => 529 Make_Attribute_Reference (Loc, 530 Prefix => New_Occurrence_Of (E, Loc), 531 Attribute_Name => Name_Alignment)), 532 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), 533 Reason => PE_Misaligned_Address_Value), 534 Suppress => All_Checks); 535 end if; 536 end if; 537 538 return; 539 540 exception 541 when RE_Not_Available => 542 return; 543 end Apply_Alignment_Check; 544 545 ------------------------------------- 546 -- Apply_Arithmetic_Overflow_Check -- 547 ------------------------------------- 548 549 -- This routine is called only if the type is an integer type, and 550 -- a software arithmetic overflow check must be performed for op 551 -- (add, subtract, multiply). The check is performed only if 552 -- Software_Overflow_Checking is enabled and Do_Overflow_Check 553 -- is set. In this case we expand the operation into a more complex 554 -- sequence of tests that ensures that overflow is properly caught. 555 556 procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is 557 Loc : constant Source_Ptr := Sloc (N); 558 Typ : constant Entity_Id := Etype (N); 559 Rtyp : constant Entity_Id := Root_Type (Typ); 560 Siz : constant Int := UI_To_Int (Esize (Rtyp)); 561 Dsiz : constant Int := Siz * 2; 562 Opnod : Node_Id; 563 Ctyp : Entity_Id; 564 Opnd : Node_Id; 565 Cent : RE_Id; 566 567 begin 568 -- Skip this if overflow checks are done in back end, or the overflow 569 -- flag is not set anyway, or we are not doing code expansion. 570 571 if Backend_Overflow_Checks_On_Target 572 or not Do_Overflow_Check (N) 573 or not Expander_Active 574 then 575 return; 576 end if; 577 578 -- Otherwise, we generate the full general code for front end overflow 579 -- detection, which works by doing arithmetic in a larger type: 580 581 -- x op y 582 583 -- is expanded into 584 585 -- Typ (Checktyp (x) op Checktyp (y)); 586 587 -- where Typ is the type of the original expression, and Checktyp is 588 -- an integer type of sufficient length to hold the largest possible 589 -- result. 590 591 -- In the case where check type exceeds the size of Long_Long_Integer, 592 -- we use a different approach, expanding to: 593 594 -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y))) 595 596 -- where xxx is Add, Multiply or Subtract as appropriate 597 598 -- Find check type if one exists 599 600 if Dsiz <= Standard_Integer_Size then 601 Ctyp := Standard_Integer; 602 603 elsif Dsiz <= Standard_Long_Long_Integer_Size then 604 Ctyp := Standard_Long_Long_Integer; 605 606 -- No check type exists, use runtime call 607 608 else 609 if Nkind (N) = N_Op_Add then 610 Cent := RE_Add_With_Ovflo_Check; 611 612 elsif Nkind (N) = N_Op_Multiply then 613 Cent := RE_Multiply_With_Ovflo_Check; 614 615 else 616 pragma Assert (Nkind (N) = N_Op_Subtract); 617 Cent := RE_Subtract_With_Ovflo_Check; 618 end if; 619 620 Rewrite (N, 621 OK_Convert_To (Typ, 622 Make_Function_Call (Loc, 623 Name => New_Reference_To (RTE (Cent), Loc), 624 Parameter_Associations => New_List ( 625 OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)), 626 OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N)))))); 627 628 Analyze_And_Resolve (N, Typ); 629 return; 630 end if; 631 632 -- If we fall through, we have the case where we do the arithmetic in 633 -- the next higher type and get the check by conversion. In these cases 634 -- Ctyp is set to the type to be used as the check type. 635 636 Opnod := Relocate_Node (N); 637 638 Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod)); 639 640 Analyze (Opnd); 641 Set_Etype (Opnd, Ctyp); 642 Set_Analyzed (Opnd, True); 643 Set_Left_Opnd (Opnod, Opnd); 644 645 Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod)); 646 647 Analyze (Opnd); 648 Set_Etype (Opnd, Ctyp); 649 Set_Analyzed (Opnd, True); 650 Set_Right_Opnd (Opnod, Opnd); 651 652 -- The type of the operation changes to the base type of the check 653 -- type, and we reset the overflow check indication, since clearly 654 -- no overflow is possible now that we are using a double length 655 -- type. We also set the Analyzed flag to avoid a recursive attempt 656 -- to expand the node. 657 658 Set_Etype (Opnod, Base_Type (Ctyp)); 659 Set_Do_Overflow_Check (Opnod, False); 660 Set_Analyzed (Opnod, True); 661 662 -- Now build the outer conversion 663 664 Opnd := OK_Convert_To (Typ, Opnod); 665 Analyze (Opnd); 666 Set_Etype (Opnd, Typ); 667 668 -- In the discrete type case, we directly generate the range check 669 -- for the outer operand. This range check will implement the required 670 -- overflow check. 671 672 if Is_Discrete_Type (Typ) then 673 Rewrite (N, Opnd); 674 Generate_Range_Check (Expression (N), Typ, CE_Overflow_Check_Failed); 675 676 -- For other types, we enable overflow checking on the conversion, 677 -- after setting the node as analyzed to prevent recursive attempts 678 -- to expand the conversion node. 679 680 else 681 Set_Analyzed (Opnd, True); 682 Enable_Overflow_Check (Opnd); 683 Rewrite (N, Opnd); 684 end if; 685 686 exception 687 when RE_Not_Available => 688 return; 689 end Apply_Arithmetic_Overflow_Check; 690 691 ---------------------------- 692 -- Apply_Array_Size_Check -- 693 ---------------------------- 694 695 -- Note: Really of course this entre check should be in the backend, 696 -- and perhaps this is not quite the right value, but it is good 697 -- enough to catch the normal cases (and the relevant ACVC tests!) 698 699 procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is 700 Loc : constant Source_Ptr := Sloc (N); 701 Ctyp : constant Entity_Id := Component_Type (Typ); 702 Ent : constant Entity_Id := Defining_Identifier (N); 703 Decl : Node_Id; 704 Lo : Node_Id; 705 Hi : Node_Id; 706 Lob : Uint; 707 Hib : Uint; 708 Siz : Uint; 709 Xtyp : Entity_Id; 710 Indx : Node_Id; 711 Sizx : Node_Id; 712 Code : Node_Id; 713 714 Static : Boolean := True; 715 -- Set false if any index subtye bound is non-static 716 717 Umark : constant Uintp.Save_Mark := Uintp.Mark; 718 -- We can throw away all the Uint computations here, since they are 719 -- done only to generate boolean test results. 720 721 Check_Siz : Uint; 722 -- Size to check against 723 724 function Is_Address_Or_Import (Decl : Node_Id) return Boolean; 725 -- Determines if Decl is an address clause or Import/Interface pragma 726 -- that references the defining identifier of the current declaration. 727 728 -------------------------- 729 -- Is_Address_Or_Import -- 730 -------------------------- 731 732 function Is_Address_Or_Import (Decl : Node_Id) return Boolean is 733 begin 734 if Nkind (Decl) = N_At_Clause then 735 return Chars (Identifier (Decl)) = Chars (Ent); 736 737 elsif Nkind (Decl) = N_Attribute_Definition_Clause then 738 return 739 Chars (Decl) = Name_Address 740 and then 741 Nkind (Name (Decl)) = N_Identifier 742 and then 743 Chars (Name (Decl)) = Chars (Ent); 744 745 elsif Nkind (Decl) = N_Pragma then 746 if (Chars (Decl) = Name_Import 747 or else 748 Chars (Decl) = Name_Interface) 749 and then Present (Pragma_Argument_Associations (Decl)) 750 then 751 declare 752 F : constant Node_Id := 753 First (Pragma_Argument_Associations (Decl)); 754 755 begin 756 return 757 Present (F) 758 and then 759 Present (Next (F)) 760 and then 761 Nkind (Expression (Next (F))) = N_Identifier 762 and then 763 Chars (Expression (Next (F))) = Chars (Ent); 764 end; 765 766 else 767 return False; 768 end if; 769 770 else 771 return False; 772 end if; 773 end Is_Address_Or_Import; 774 775 -- Start of processing for Apply_Array_Size_Check 776 777 begin 778 if not Expander_Active 779 or else Storage_Checks_Suppressed (Typ) 780 then 781 return; 782 end if; 783 784 -- It is pointless to insert this check inside an init proc, because 785 -- that's too late, we have already built the object to be the right 786 -- size, and if it's too large, too bad! 787 788 if Inside_Init_Proc then 789 return; 790 end if; 791 792 -- Look head for pragma interface/import or address clause applying 793 -- to this entity. If found, we suppress the check entirely. For now 794 -- we only look ahead 20 declarations to stop this becoming too slow 795 -- Note that eventually this whole routine gets moved to gigi. 796 797 Decl := N; 798 for Ctr in 1 .. 20 loop 799 Next (Decl); 800 exit when No (Decl); 801 802 if Is_Address_Or_Import (Decl) then 803 return; 804 end if; 805 end loop; 806 807 -- First step is to calculate the maximum number of elements. For this 808 -- calculation, we use the actual size of the subtype if it is static, 809 -- and if a bound of a subtype is non-static, we go to the bound of the 810 -- base type. 811 812 Siz := Uint_1; 813 Indx := First_Index (Typ); 814 while Present (Indx) loop 815 Xtyp := Etype (Indx); 816 Lo := Type_Low_Bound (Xtyp); 817 Hi := Type_High_Bound (Xtyp); 818 819 -- If any bound raises constraint error, we will never get this 820 -- far, so there is no need to generate any kind of check. 821 822 if Raises_Constraint_Error (Lo) 823 or else 824 Raises_Constraint_Error (Hi) 825 then 826 Uintp.Release (Umark); 827 return; 828 end if; 829 830 -- Otherwise get bounds values 831 832 if Is_Static_Expression (Lo) then 833 Lob := Expr_Value (Lo); 834 else 835 Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp))); 836 Static := False; 837 end if; 838 839 if Is_Static_Expression (Hi) then 840 Hib := Expr_Value (Hi); 841 else 842 Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp))); 843 Static := False; 844 end if; 845 846 Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0); 847 Next_Index (Indx); 848 end loop; 849 850 -- Compute the limit against which we want to check. For subprograms, 851 -- where the array will go on the stack, we use 8*2**24, which (in 852 -- bits) is the size of a 16 megabyte array. 853 854 if Is_Subprogram (Scope (Ent)) then 855 Check_Siz := Uint_2 ** 27; 856 else 857 Check_Siz := Uint_2 ** 31; 858 end if; 859 860 -- If we have all static bounds and Siz is too large, then we know we 861 -- know we have a storage error right now, so generate message 862 863 if Static and then Siz >= Check_Siz then 864 Insert_Action (N, 865 Make_Raise_Storage_Error (Loc, 866 Reason => SE_Object_Too_Large)); 867 Error_Msg_N ("?Storage_Error will be raised at run-time", N); 868 Uintp.Release (Umark); 869 return; 870 end if; 871 872 -- Case of component size known at compile time. If the array 873 -- size is definitely in range, then we do not need a check. 874 875 if Known_Esize (Ctyp) 876 and then Siz * Esize (Ctyp) < Check_Siz 877 then 878 Uintp.Release (Umark); 879 return; 880 end if; 881 882 -- Here if a dynamic check is required 883 884 -- What we do is to build an expression for the size of the array, 885 -- which is computed as the 'Size of the array component, times 886 -- the size of each dimension. 887 888 Uintp.Release (Umark); 889 890 Sizx := 891 Make_Attribute_Reference (Loc, 892 Prefix => New_Occurrence_Of (Ctyp, Loc), 893 Attribute_Name => Name_Size); 894 895 Indx := First_Index (Typ); 896 897 for J in 1 .. Number_Dimensions (Typ) loop 898 if Sloc (Etype (Indx)) = Sloc (N) then 899 Ensure_Defined (Etype (Indx), N); 900 end if; 901 902 Sizx := 903 Make_Op_Multiply (Loc, 904 Left_Opnd => Sizx, 905 Right_Opnd => 906 Make_Attribute_Reference (Loc, 907 Prefix => New_Occurrence_Of (Typ, Loc), 908 Attribute_Name => Name_Length, 909 Expressions => New_List ( 910 Make_Integer_Literal (Loc, J)))); 911 Next_Index (Indx); 912 end loop; 913 914 Code := 915 Make_Raise_Storage_Error (Loc, 916 Condition => 917 Make_Op_Ge (Loc, 918 Left_Opnd => Sizx, 919 Right_Opnd => 920 Make_Integer_Literal (Loc, Check_Siz)), 921 Reason => SE_Object_Too_Large); 922 923 Set_Size_Check_Code (Defining_Identifier (N), Code); 924 Insert_Action (N, Code); 925 end Apply_Array_Size_Check; 926 927 ---------------------------- 928 -- Apply_Constraint_Check -- 929 ---------------------------- 930 931 procedure Apply_Constraint_Check 932 (N : Node_Id; 933 Typ : Entity_Id; 934 No_Sliding : Boolean := False) 935 is 936 Desig_Typ : Entity_Id; 937 938 begin 939 if Inside_A_Generic then 940 return; 941 942 elsif Is_Scalar_Type (Typ) then 943 Apply_Scalar_Range_Check (N, Typ); 944 945 elsif Is_Array_Type (Typ) then 946 947 -- A useful optimization: an aggregate with only an Others clause 948 -- always has the right bounds. 949 950 if Nkind (N) = N_Aggregate 951 and then No (Expressions (N)) 952 and then Nkind 953 (First (Choices (First (Component_Associations (N))))) 954 = N_Others_Choice 955 then 956 return; 957 end if; 958 959 if Is_Constrained (Typ) then 960 Apply_Length_Check (N, Typ); 961 962 if No_Sliding then 963 Apply_Range_Check (N, Typ); 964 end if; 965 else 966 Apply_Range_Check (N, Typ); 967 end if; 968 969 elsif (Is_Record_Type (Typ) 970 or else Is_Private_Type (Typ)) 971 and then Has_Discriminants (Base_Type (Typ)) 972 and then Is_Constrained (Typ) 973 then 974 Apply_Discriminant_Check (N, Typ); 975 976 elsif Is_Access_Type (Typ) then 977 978 Desig_Typ := Designated_Type (Typ); 979 980 -- No checks necessary if expression statically null 981 982 if Nkind (N) = N_Null then 983 null; 984 985 -- No sliding possible on access to arrays 986 987 elsif Is_Array_Type (Desig_Typ) then 988 if Is_Constrained (Desig_Typ) then 989 Apply_Length_Check (N, Typ); 990 end if; 991 992 Apply_Range_Check (N, Typ); 993 994 elsif Has_Discriminants (Base_Type (Desig_Typ)) 995 and then Is_Constrained (Desig_Typ) 996 then 997 Apply_Discriminant_Check (N, Typ); 998 end if; 999 end if; 1000 end Apply_Constraint_Check; 1001 1002 ------------------------------ 1003 -- Apply_Discriminant_Check -- 1004 ------------------------------ 1005 1006 procedure Apply_Discriminant_Check 1007 (N : Node_Id; 1008 Typ : Entity_Id; 1009 Lhs : Node_Id := Empty) 1010 is 1011 Loc : constant Source_Ptr := Sloc (N); 1012 Do_Access : constant Boolean := Is_Access_Type (Typ); 1013 S_Typ : Entity_Id := Etype (N); 1014 Cond : Node_Id; 1015 T_Typ : Entity_Id; 1016 1017 function Is_Aliased_Unconstrained_Component return Boolean; 1018 -- It is possible for an aliased component to have a nominal 1019 -- unconstrained subtype (through instantiation). If this is a 1020 -- discriminated component assigned in the expansion of an aggregate 1021 -- in an initialization, the check must be suppressed. This unusual 1022 -- situation requires a predicate of its own (see 7503-008). 1023 1024 ---------------------------------------- 1025 -- Is_Aliased_Unconstrained_Component -- 1026 ---------------------------------------- 1027 1028 function Is_Aliased_Unconstrained_Component return Boolean is 1029 Comp : Entity_Id; 1030 Pref : Node_Id; 1031 1032 begin 1033 if Nkind (Lhs) /= N_Selected_Component then 1034 return False; 1035 else 1036 Comp := Entity (Selector_Name (Lhs)); 1037 Pref := Prefix (Lhs); 1038 end if; 1039 1040 if Ekind (Comp) /= E_Component 1041 or else not Is_Aliased (Comp) 1042 then 1043 return False; 1044 end if; 1045 1046 return not Comes_From_Source (Pref) 1047 and then In_Instance 1048 and then not Is_Constrained (Etype (Comp)); 1049 end Is_Aliased_Unconstrained_Component; 1050 1051 -- Start of processing for Apply_Discriminant_Check 1052 1053 begin 1054 if Do_Access then 1055 T_Typ := Designated_Type (Typ); 1056 else 1057 T_Typ := Typ; 1058 end if; 1059 1060 -- Nothing to do if discriminant checks are suppressed or else no code 1061 -- is to be generated 1062 1063 if not Expander_Active 1064 or else Discriminant_Checks_Suppressed (T_Typ) 1065 then 1066 return; 1067 end if; 1068 1069 -- No discriminant checks necessary for access when expression 1070 -- is statically Null. This is not only an optimization, this is 1071 -- fundamental because otherwise discriminant checks may be generated 1072 -- in init procs for types containing an access to a non-frozen yet 1073 -- record, causing a deadly forward reference. 1074 1075 -- Also, if the expression is of an access type whose designated 1076 -- type is incomplete, then the access value must be null and 1077 -- we suppress the check. 1078 1079 if Nkind (N) = N_Null then 1080 return; 1081 1082 elsif Is_Access_Type (S_Typ) then 1083 S_Typ := Designated_Type (S_Typ); 1084 1085 if Ekind (S_Typ) = E_Incomplete_Type then 1086 return; 1087 end if; 1088 end if; 1089 1090 -- If an assignment target is present, then we need to generate 1091 -- the actual subtype if the target is a parameter or aliased 1092 -- object with an unconstrained nominal subtype. 1093 1094 if Present (Lhs) 1095 and then (Present (Param_Entity (Lhs)) 1096 or else (not Is_Constrained (T_Typ) 1097 and then Is_Aliased_View (Lhs) 1098 and then not Is_Aliased_Unconstrained_Component)) 1099 then 1100 T_Typ := Get_Actual_Subtype (Lhs); 1101 end if; 1102 1103 -- Nothing to do if the type is unconstrained (this is the case 1104 -- where the actual subtype in the RM sense of N is unconstrained 1105 -- and no check is required). 1106 1107 if not Is_Constrained (T_Typ) then 1108 return; 1109 end if; 1110 1111 -- Suppress checks if the subtypes are the same. 1112 -- the check must be preserved in an assignment to a formal, because 1113 -- the constraint is given by the actual. 1114 1115 if Nkind (Original_Node (N)) /= N_Allocator 1116 and then (No (Lhs) 1117 or else not Is_Entity_Name (Lhs) 1118 or else No (Param_Entity (Lhs))) 1119 then 1120 if (Etype (N) = Typ 1121 or else (Do_Access and then Designated_Type (Typ) = S_Typ)) 1122 and then not Is_Aliased_View (Lhs) 1123 then 1124 return; 1125 end if; 1126 1127 -- We can also eliminate checks on allocators with a subtype mark 1128 -- that coincides with the context type. The context type may be a 1129 -- subtype without a constraint (common case, a generic actual). 1130 1131 elsif Nkind (Original_Node (N)) = N_Allocator 1132 and then Is_Entity_Name (Expression (Original_Node (N))) 1133 then 1134 declare 1135 Alloc_Typ : constant Entity_Id := 1136 Entity (Expression (Original_Node (N))); 1137 1138 begin 1139 if Alloc_Typ = T_Typ 1140 or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration 1141 and then Is_Entity_Name ( 1142 Subtype_Indication (Parent (T_Typ))) 1143 and then Alloc_Typ = Base_Type (T_Typ)) 1144 1145 then 1146 return; 1147 end if; 1148 end; 1149 end if; 1150 1151 -- See if we have a case where the types are both constrained, and 1152 -- all the constraints are constants. In this case, we can do the 1153 -- check successfully at compile time. 1154 1155 -- We skip this check for the case where the node is a rewritten` 1156 -- allocator, because it already carries the context subtype, and 1157 -- extracting the discriminants from the aggregate is messy. 1158 1159 if Is_Constrained (S_Typ) 1160 and then Nkind (Original_Node (N)) /= N_Allocator 1161 then 1162 declare 1163 DconT : Elmt_Id; 1164 Discr : Entity_Id; 1165 DconS : Elmt_Id; 1166 ItemS : Node_Id; 1167 ItemT : Node_Id; 1168 1169 begin 1170 -- S_Typ may not have discriminants in the case where it is a 1171 -- private type completed by a default discriminated type. In 1172 -- that case, we need to get the constraints from the 1173 -- underlying_type. If the underlying type is unconstrained (i.e. 1174 -- has no default discriminants) no check is needed. 1175 1176 if Has_Discriminants (S_Typ) then 1177 Discr := First_Discriminant (S_Typ); 1178 DconS := First_Elmt (Discriminant_Constraint (S_Typ)); 1179 1180 else 1181 Discr := First_Discriminant (Underlying_Type (S_Typ)); 1182 DconS := 1183 First_Elmt 1184 (Discriminant_Constraint (Underlying_Type (S_Typ))); 1185 1186 if No (DconS) then 1187 return; 1188 end if; 1189 1190 -- A further optimization: if T_Typ is derived from S_Typ 1191 -- without imposing a constraint, no check is needed. 1192 1193 if Nkind (Original_Node (Parent (T_Typ))) = 1194 N_Full_Type_Declaration 1195 then 1196 declare 1197 Type_Def : constant Node_Id := 1198 Type_Definition 1199 (Original_Node (Parent (T_Typ))); 1200 begin 1201 if Nkind (Type_Def) = N_Derived_Type_Definition 1202 and then Is_Entity_Name (Subtype_Indication (Type_Def)) 1203 and then Entity (Subtype_Indication (Type_Def)) = S_Typ 1204 then 1205 return; 1206 end if; 1207 end; 1208 end if; 1209 end if; 1210 1211 DconT := First_Elmt (Discriminant_Constraint (T_Typ)); 1212 1213 while Present (Discr) loop 1214 ItemS := Node (DconS); 1215 ItemT := Node (DconT); 1216 1217 exit when 1218 not Is_OK_Static_Expression (ItemS) 1219 or else 1220 not Is_OK_Static_Expression (ItemT); 1221 1222 if Expr_Value (ItemS) /= Expr_Value (ItemT) then 1223 if Do_Access then -- needs run-time check. 1224 exit; 1225 else 1226 Apply_Compile_Time_Constraint_Error 1227 (N, "incorrect value for discriminant&?", 1228 CE_Discriminant_Check_Failed, Ent => Discr); 1229 return; 1230 end if; 1231 end if; 1232 1233 Next_Elmt (DconS); 1234 Next_Elmt (DconT); 1235 Next_Discriminant (Discr); 1236 end loop; 1237 1238 if No (Discr) then 1239 return; 1240 end if; 1241 end; 1242 end if; 1243 1244 -- Here we need a discriminant check. First build the expression 1245 -- for the comparisons of the discriminants: 1246 1247 -- (n.disc1 /= typ.disc1) or else 1248 -- (n.disc2 /= typ.disc2) or else 1249 -- ... 1250 -- (n.discn /= typ.discn) 1251 1252 Cond := Build_Discriminant_Checks (N, T_Typ); 1253 1254 -- If Lhs is set and is a parameter, then the condition is 1255 -- guarded by: lhs'constrained and then (condition built above) 1256 1257 if Present (Param_Entity (Lhs)) then 1258 Cond := 1259 Make_And_Then (Loc, 1260 Left_Opnd => 1261 Make_Attribute_Reference (Loc, 1262 Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc), 1263 Attribute_Name => Name_Constrained), 1264 Right_Opnd => Cond); 1265 end if; 1266 1267 if Do_Access then 1268 Cond := Guard_Access (Cond, Loc, N); 1269 end if; 1270 1271 Insert_Action (N, 1272 Make_Raise_Constraint_Error (Loc, 1273 Condition => Cond, 1274 Reason => CE_Discriminant_Check_Failed)); 1275 end Apply_Discriminant_Check; 1276 1277 ------------------------ 1278 -- Apply_Divide_Check -- 1279 ------------------------ 1280 1281 procedure Apply_Divide_Check (N : Node_Id) is 1282 Loc : constant Source_Ptr := Sloc (N); 1283 Typ : constant Entity_Id := Etype (N); 1284 Left : constant Node_Id := Left_Opnd (N); 1285 Right : constant Node_Id := Right_Opnd (N); 1286 1287 LLB : Uint; 1288 Llo : Uint; 1289 Lhi : Uint; 1290 LOK : Boolean; 1291 Rlo : Uint; 1292 Rhi : Uint; 1293 ROK : Boolean; 1294 1295 begin 1296 if Expander_Active 1297 and not Backend_Divide_Checks_On_Target 1298 then 1299 Determine_Range (Right, ROK, Rlo, Rhi); 1300 1301 -- See if division by zero possible, and if so generate test. This 1302 -- part of the test is not controlled by the -gnato switch. 1303 1304 if Do_Division_Check (N) then 1305 1306 if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then 1307 Insert_Action (N, 1308 Make_Raise_Constraint_Error (Loc, 1309 Condition => 1310 Make_Op_Eq (Loc, 1311 Left_Opnd => Duplicate_Subexpr_Move_Checks (Right), 1312 Right_Opnd => Make_Integer_Literal (Loc, 0)), 1313 Reason => CE_Divide_By_Zero)); 1314 end if; 1315 end if; 1316 1317 -- Test for extremely annoying case of xxx'First divided by -1 1318 1319 if Do_Overflow_Check (N) then 1320 1321 if Nkind (N) = N_Op_Divide 1322 and then Is_Signed_Integer_Type (Typ) 1323 then 1324 Determine_Range (Left, LOK, Llo, Lhi); 1325 LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ))); 1326 1327 if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) 1328 and then 1329 ((not LOK) or else (Llo = LLB)) 1330 then 1331 Insert_Action (N, 1332 Make_Raise_Constraint_Error (Loc, 1333 Condition => 1334 Make_And_Then (Loc, 1335 1336 Make_Op_Eq (Loc, 1337 Left_Opnd => 1338 Duplicate_Subexpr_Move_Checks (Left), 1339 Right_Opnd => Make_Integer_Literal (Loc, LLB)), 1340 1341 Make_Op_Eq (Loc, 1342 Left_Opnd => 1343 Duplicate_Subexpr (Right), 1344 Right_Opnd => 1345 Make_Integer_Literal (Loc, -1))), 1346 Reason => CE_Overflow_Check_Failed)); 1347 end if; 1348 end if; 1349 end if; 1350 end if; 1351 end Apply_Divide_Check; 1352 1353 ------------------------ 1354 -- Apply_Length_Check -- 1355 ------------------------ 1356 1357 procedure Apply_Length_Check 1358 (Ck_Node : Node_Id; 1359 Target_Typ : Entity_Id; 1360 Source_Typ : Entity_Id := Empty) 1361 is 1362 begin 1363 Apply_Selected_Length_Checks 1364 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False); 1365 end Apply_Length_Check; 1366 1367 ----------------------- 1368 -- Apply_Range_Check -- 1369 ----------------------- 1370 1371 procedure Apply_Range_Check 1372 (Ck_Node : Node_Id; 1373 Target_Typ : Entity_Id; 1374 Source_Typ : Entity_Id := Empty) 1375 is 1376 begin 1377 Apply_Selected_Range_Checks 1378 (Ck_Node, Target_Typ, Source_Typ, Do_Static => False); 1379 end Apply_Range_Check; 1380 1381 ------------------------------ 1382 -- Apply_Scalar_Range_Check -- 1383 ------------------------------ 1384 1385 -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check 1386 -- flag off if it is already set on. 1387 1388 procedure Apply_Scalar_Range_Check 1389 (Expr : Node_Id; 1390 Target_Typ : Entity_Id; 1391 Source_Typ : Entity_Id := Empty; 1392 Fixed_Int : Boolean := False) 1393 is 1394 Parnt : constant Node_Id := Parent (Expr); 1395 S_Typ : Entity_Id; 1396 Arr : Node_Id := Empty; -- initialize to prevent warning 1397 Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning 1398 OK : Boolean; 1399 1400 Is_Subscr_Ref : Boolean; 1401 -- Set true if Expr is a subscript 1402 1403 Is_Unconstrained_Subscr_Ref : Boolean; 1404 -- Set true if Expr is a subscript of an unconstrained array. In this 1405 -- case we do not attempt to do an analysis of the value against the 1406 -- range of the subscript, since we don't know the actual subtype. 1407 1408 Int_Real : Boolean; 1409 -- Set to True if Expr should be regarded as a real value 1410 -- even though the type of Expr might be discrete. 1411 1412 procedure Bad_Value; 1413 -- Procedure called if value is determined to be out of range 1414 1415 --------------- 1416 -- Bad_Value -- 1417 --------------- 1418 1419 procedure Bad_Value is 1420 begin 1421 Apply_Compile_Time_Constraint_Error 1422 (Expr, "value not in range of}?", CE_Range_Check_Failed, 1423 Ent => Target_Typ, 1424 Typ => Target_Typ); 1425 end Bad_Value; 1426 1427 -- Start of processing for Apply_Scalar_Range_Check 1428 1429 begin 1430 if Inside_A_Generic then 1431 return; 1432 1433 -- Return if check obviously not needed. Note that we do not check 1434 -- for the expander being inactive, since this routine does not 1435 -- insert any code, but it does generate useful warnings sometimes, 1436 -- which we would like even if we are in semantics only mode. 1437 1438 elsif Target_Typ = Any_Type 1439 or else not Is_Scalar_Type (Target_Typ) 1440 or else Raises_Constraint_Error (Expr) 1441 then 1442 return; 1443 end if; 1444 1445 -- Now, see if checks are suppressed 1446 1447 Is_Subscr_Ref := 1448 Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component; 1449 1450 if Is_Subscr_Ref then 1451 Arr := Prefix (Parnt); 1452 Arr_Typ := Get_Actual_Subtype_If_Available (Arr); 1453 end if; 1454 1455 if not Do_Range_Check (Expr) then 1456 1457 -- Subscript reference. Check for Index_Checks suppressed 1458 1459 if Is_Subscr_Ref then 1460 1461 -- Check array type and its base type 1462 1463 if Index_Checks_Suppressed (Arr_Typ) 1464 or else Index_Checks_Suppressed (Base_Type (Arr_Typ)) 1465 then 1466 return; 1467 1468 -- Check array itself if it is an entity name 1469 1470 elsif Is_Entity_Name (Arr) 1471 and then Index_Checks_Suppressed (Entity (Arr)) 1472 then 1473 return; 1474 1475 -- Check expression itself if it is an entity name 1476 1477 elsif Is_Entity_Name (Expr) 1478 and then Index_Checks_Suppressed (Entity (Expr)) 1479 then 1480 return; 1481 end if; 1482 1483 -- All other cases, check for Range_Checks suppressed 1484 1485 else 1486 -- Check target type and its base type 1487 1488 if Range_Checks_Suppressed (Target_Typ) 1489 or else Range_Checks_Suppressed (Base_Type (Target_Typ)) 1490 then 1491 return; 1492 1493 -- Check expression itself if it is an entity name 1494 1495 elsif Is_Entity_Name (Expr) 1496 and then Range_Checks_Suppressed (Entity (Expr)) 1497 then 1498 return; 1499 1500 -- If Expr is part of an assignment statement, then check 1501 -- left side of assignment if it is an entity name. 1502 1503 elsif Nkind (Parnt) = N_Assignment_Statement 1504 and then Is_Entity_Name (Name (Parnt)) 1505 and then Range_Checks_Suppressed (Entity (Name (Parnt))) 1506 then 1507 return; 1508 end if; 1509 end if; 1510 end if; 1511 1512 -- Do not set range checks if they are killed 1513 1514 if Nkind (Expr) = N_Unchecked_Type_Conversion 1515 and then Kill_Range_Check (Expr) 1516 then 1517 return; 1518 end if; 1519 1520 -- Do not set range checks for any values from System.Scalar_Values 1521 -- since the whole idea of such values is to avoid checking them! 1522 1523 if Is_Entity_Name (Expr) 1524 and then Is_RTU (Scope (Entity (Expr)), System_Scalar_Values) 1525 then 1526 return; 1527 end if; 1528 1529 -- Now see if we need a check 1530 1531 if No (Source_Typ) then 1532 S_Typ := Etype (Expr); 1533 else 1534 S_Typ := Source_Typ; 1535 end if; 1536 1537 if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then 1538 return; 1539 end if; 1540 1541 Is_Unconstrained_Subscr_Ref := 1542 Is_Subscr_Ref and then not Is_Constrained (Arr_Typ); 1543 1544 -- Always do a range check if the source type includes infinities 1545 -- and the target type does not include infinities. We do not do 1546 -- this if range checks are killed. 1547 1548 if Is_Floating_Point_Type (S_Typ) 1549 and then Has_Infinities (S_Typ) 1550 and then not Has_Infinities (Target_Typ) 1551 then 1552 Enable_Range_Check (Expr); 1553 end if; 1554 1555 -- Return if we know expression is definitely in the range of 1556 -- the target type as determined by Determine_Range. Right now 1557 -- we only do this for discrete types, and not fixed-point or 1558 -- floating-point types. 1559 1560 -- The additional less-precise tests below catch these cases. 1561 1562 -- Note: skip this if we are given a source_typ, since the point 1563 -- of supplying a Source_Typ is to stop us looking at the expression. 1564 -- could sharpen this test to be out parameters only ??? 1565 1566 if Is_Discrete_Type (Target_Typ) 1567 and then Is_Discrete_Type (Etype (Expr)) 1568 and then not Is_Unconstrained_Subscr_Ref 1569 and then No (Source_Typ) 1570 then 1571 declare 1572 Tlo : constant Node_Id := Type_Low_Bound (Target_Typ); 1573 Thi : constant Node_Id := Type_High_Bound (Target_Typ); 1574 Lo : Uint; 1575 Hi : Uint; 1576 1577 begin 1578 if Compile_Time_Known_Value (Tlo) 1579 and then Compile_Time_Known_Value (Thi) 1580 then 1581 declare 1582 Lov : constant Uint := Expr_Value (Tlo); 1583 Hiv : constant Uint := Expr_Value (Thi); 1584 1585 begin 1586 -- If range is null, we for sure have a constraint error 1587 -- (we don't even need to look at the value involved, 1588 -- since all possible values will raise CE). 1589 1590 if Lov > Hiv then 1591 Bad_Value; 1592 return; 1593 end if; 1594 1595 -- Otherwise determine range of value 1596 1597 Determine_Range (Expr, OK, Lo, Hi); 1598 1599 if OK then 1600 1601 -- If definitely in range, all OK 1602 1603 if Lo >= Lov and then Hi <= Hiv then 1604 return; 1605 1606 -- If definitely not in range, warn 1607 1608 elsif Lov > Hi or else Hiv < Lo then 1609 Bad_Value; 1610 return; 1611 1612 -- Otherwise we don't know 1613 1614 else 1615 null; 1616 end if; 1617 end if; 1618 end; 1619 end if; 1620 end; 1621 end if; 1622 1623 Int_Real := 1624 Is_Floating_Point_Type (S_Typ) 1625 or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int); 1626 1627 -- Check if we can determine at compile time whether Expr is in the 1628 -- range of the target type. Note that if S_Typ is within the bounds 1629 -- of Target_Typ then this must be the case. This check is meaningful 1630 -- only if this is not a conversion between integer and real types. 1631 1632 if not Is_Unconstrained_Subscr_Ref 1633 and then 1634 Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ) 1635 and then 1636 (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int) 1637 or else 1638 Is_In_Range (Expr, Target_Typ, Fixed_Int, Int_Real)) 1639 then 1640 return; 1641 1642 elsif Is_Out_Of_Range (Expr, Target_Typ, Fixed_Int, Int_Real) then 1643 Bad_Value; 1644 return; 1645 1646 -- In the floating-point case, we only do range checks if the 1647 -- type is constrained. We definitely do NOT want range checks 1648 -- for unconstrained types, since we want to have infinities 1649 1650 elsif Is_Floating_Point_Type (S_Typ) then 1651 if Is_Constrained (S_Typ) then 1652 Enable_Range_Check (Expr); 1653 end if; 1654 1655 -- For all other cases we enable a range check unconditionally 1656 1657 else 1658 Enable_Range_Check (Expr); 1659 return; 1660 end if; 1661 end Apply_Scalar_Range_Check; 1662 1663 ---------------------------------- 1664 -- Apply_Selected_Length_Checks -- 1665 ---------------------------------- 1666 1667 procedure Apply_Selected_Length_Checks 1668 (Ck_Node : Node_Id; 1669 Target_Typ : Entity_Id; 1670 Source_Typ : Entity_Id; 1671 Do_Static : Boolean) 1672 is 1673 Cond : Node_Id; 1674 R_Result : Check_Result; 1675 R_Cno : Node_Id; 1676 1677 Loc : constant Source_Ptr := Sloc (Ck_Node); 1678 Checks_On : constant Boolean := 1679 (not Index_Checks_Suppressed (Target_Typ)) 1680 or else 1681 (not Length_Checks_Suppressed (Target_Typ)); 1682 1683 begin 1684 if not Expander_Active then 1685 return; 1686 end if; 1687 1688 R_Result := 1689 Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty); 1690 1691 for J in 1 .. 2 loop 1692 R_Cno := R_Result (J); 1693 exit when No (R_Cno); 1694 1695 -- A length check may mention an Itype which is attached to a 1696 -- subsequent node. At the top level in a package this can cause 1697 -- an order-of-elaboration problem, so we make sure that the itype 1698 -- is referenced now. 1699 1700 if Ekind (Current_Scope) = E_Package 1701 and then Is_Compilation_Unit (Current_Scope) 1702 then 1703 Ensure_Defined (Target_Typ, Ck_Node); 1704 1705 if Present (Source_Typ) then 1706 Ensure_Defined (Source_Typ, Ck_Node); 1707 1708 elsif Is_Itype (Etype (Ck_Node)) then 1709 Ensure_Defined (Etype (Ck_Node), Ck_Node); 1710 end if; 1711 end if; 1712 1713 -- If the item is a conditional raise of constraint error, 1714 -- then have a look at what check is being performed and 1715 -- ??? 1716 1717 if Nkind (R_Cno) = N_Raise_Constraint_Error 1718 and then Present (Condition (R_Cno)) 1719 then 1720 Cond := Condition (R_Cno); 1721 1722 if not Has_Dynamic_Length_Check (Ck_Node) 1723 and then Checks_On 1724 then 1725 Insert_Action (Ck_Node, R_Cno); 1726 1727 if not Do_Static then 1728 Set_Has_Dynamic_Length_Check (Ck_Node); 1729 end if; 1730 end if; 1731 1732 -- Output a warning if the condition is known to be True 1733 1734 if Is_Entity_Name (Cond) 1735 and then Entity (Cond) = Standard_True 1736 then 1737 Apply_Compile_Time_Constraint_Error 1738 (Ck_Node, "wrong length for array of}?", 1739 CE_Length_Check_Failed, 1740 Ent => Target_Typ, 1741 Typ => Target_Typ); 1742 1743 -- If we were only doing a static check, or if checks are not 1744 -- on, then we want to delete the check, since it is not needed. 1745 -- We do this by replacing the if statement by a null statement 1746 1747 elsif Do_Static or else not Checks_On then 1748 Rewrite (R_Cno, Make_Null_Statement (Loc)); 1749 end if; 1750 1751 else 1752 Install_Static_Check (R_Cno, Loc); 1753 end if; 1754 1755 end loop; 1756 1757 end Apply_Selected_Length_Checks; 1758 1759 --------------------------------- 1760 -- Apply_Selected_Range_Checks -- 1761 --------------------------------- 1762 1763 procedure Apply_Selected_Range_Checks 1764 (Ck_Node : Node_Id; 1765 Target_Typ : Entity_Id; 1766 Source_Typ : Entity_Id; 1767 Do_Static : Boolean) 1768 is 1769 Cond : Node_Id; 1770 R_Result : Check_Result; 1771 R_Cno : Node_Id; 1772 1773 Loc : constant Source_Ptr := Sloc (Ck_Node); 1774 Checks_On : constant Boolean := 1775 (not Index_Checks_Suppressed (Target_Typ)) 1776 or else 1777 (not Range_Checks_Suppressed (Target_Typ)); 1778 1779 begin 1780 if not Expander_Active or else not Checks_On then 1781 return; 1782 end if; 1783 1784 R_Result := 1785 Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty); 1786 1787 for J in 1 .. 2 loop 1788 1789 R_Cno := R_Result (J); 1790 exit when No (R_Cno); 1791 1792 -- If the item is a conditional raise of constraint error, 1793 -- then have a look at what check is being performed and 1794 -- ??? 1795 1796 if Nkind (R_Cno) = N_Raise_Constraint_Error 1797 and then Present (Condition (R_Cno)) 1798 then 1799 Cond := Condition (R_Cno); 1800 1801 if not Has_Dynamic_Range_Check (Ck_Node) then 1802 Insert_Action (Ck_Node, R_Cno); 1803 1804 if not Do_Static then 1805 Set_Has_Dynamic_Range_Check (Ck_Node); 1806 end if; 1807 end if; 1808 1809 -- Output a warning if the condition is known to be True 1810 1811 if Is_Entity_Name (Cond) 1812 and then Entity (Cond) = Standard_True 1813 then 1814 -- Since an N_Range is technically not an expression, we 1815 -- have to set one of the bounds to C_E and then just flag 1816 -- the N_Range. The warning message will point to the 1817 -- lower bound and complain about a range, which seems OK. 1818 1819 if Nkind (Ck_Node) = N_Range then 1820 Apply_Compile_Time_Constraint_Error 1821 (Low_Bound (Ck_Node), "static range out of bounds of}?", 1822 CE_Range_Check_Failed, 1823 Ent => Target_Typ, 1824 Typ => Target_Typ); 1825 1826 Set_Raises_Constraint_Error (Ck_Node); 1827 1828 else 1829 Apply_Compile_Time_Constraint_Error 1830 (Ck_Node, "static value out of range of}?", 1831 CE_Range_Check_Failed, 1832 Ent => Target_Typ, 1833 Typ => Target_Typ); 1834 end if; 1835 1836 -- If we were only doing a static check, or if checks are not 1837 -- on, then we want to delete the check, since it is not needed. 1838 -- We do this by replacing the if statement by a null statement 1839 1840 elsif Do_Static or else not Checks_On then 1841 Rewrite (R_Cno, Make_Null_Statement (Loc)); 1842 end if; 1843 1844 else 1845 Install_Static_Check (R_Cno, Loc); 1846 end if; 1847 end loop; 1848 end Apply_Selected_Range_Checks; 1849 1850 ------------------------------- 1851 -- Apply_Static_Length_Check -- 1852 ------------------------------- 1853 1854 procedure Apply_Static_Length_Check 1855 (Expr : Node_Id; 1856 Target_Typ : Entity_Id; 1857 Source_Typ : Entity_Id := Empty) 1858 is 1859 begin 1860 Apply_Selected_Length_Checks 1861 (Expr, Target_Typ, Source_Typ, Do_Static => True); 1862 end Apply_Static_Length_Check; 1863 1864 ------------------------------------- 1865 -- Apply_Subscript_Validity_Checks -- 1866 ------------------------------------- 1867 1868 procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is 1869 Sub : Node_Id; 1870 1871 begin 1872 pragma Assert (Nkind (Expr) = N_Indexed_Component); 1873 1874 -- Loop through subscripts 1875 1876 Sub := First (Expressions (Expr)); 1877 while Present (Sub) loop 1878 1879 -- Check one subscript. Note that we do not worry about 1880 -- enumeration type with holes, since we will convert the 1881 -- value to a Pos value for the subscript, and that convert 1882 -- will do the necessary validity check. 1883 1884 Ensure_Valid (Sub, Holes_OK => True); 1885 1886 -- Move to next subscript 1887 1888 Sub := Next (Sub); 1889 end loop; 1890 end Apply_Subscript_Validity_Checks; 1891 1892 ---------------------------------- 1893 -- Apply_Type_Conversion_Checks -- 1894 ---------------------------------- 1895 1896 procedure Apply_Type_Conversion_Checks (N : Node_Id) is 1897 Target_Type : constant Entity_Id := Etype (N); 1898 Target_Base : constant Entity_Id := Base_Type (Target_Type); 1899 Expr : constant Node_Id := Expression (N); 1900 Expr_Type : constant Entity_Id := Etype (Expr); 1901 1902 begin 1903 if Inside_A_Generic then 1904 return; 1905 1906 -- Skip these checks if serious errors detected, there are some nasty 1907 -- situations of incomplete trees that blow things up. 1908 1909 elsif Serious_Errors_Detected > 0 then 1910 return; 1911 1912 -- Scalar type conversions of the form Target_Type (Expr) require 1913 -- a range check if we cannot be sure that Expr is in the base type 1914 -- of Target_Typ and also that Expr is in the range of Target_Typ. 1915 -- These are not quite the same condition from an implementation 1916 -- point of view, but clearly the second includes the first. 1917 1918 elsif Is_Scalar_Type (Target_Type) then 1919 declare 1920 Conv_OK : constant Boolean := Conversion_OK (N); 1921 -- If the Conversion_OK flag on the type conversion is set 1922 -- and no floating point type is involved in the type conversion 1923 -- then fixed point values must be read as integral values. 1924 1925 begin 1926 if not Overflow_Checks_Suppressed (Target_Base) 1927 and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK) 1928 then 1929 Set_Do_Overflow_Check (N); 1930 end if; 1931 1932 if not Range_Checks_Suppressed (Target_Type) 1933 and then not Range_Checks_Suppressed (Expr_Type) 1934 then 1935 Apply_Scalar_Range_Check 1936 (Expr, Target_Type, Fixed_Int => Conv_OK); 1937 end if; 1938 end; 1939 1940 elsif Comes_From_Source (N) 1941 and then Is_Record_Type (Target_Type) 1942 and then Is_Derived_Type (Target_Type) 1943 and then not Is_Tagged_Type (Target_Type) 1944 and then not Is_Constrained (Target_Type) 1945 and then Present (Stored_Constraint (Target_Type)) 1946 then 1947 -- An unconstrained derived type may have inherited discriminant 1948 -- Build an actual discriminant constraint list using the stored 1949 -- constraint, to verify that the expression of the parent type 1950 -- satisfies the constraints imposed by the (unconstrained!) 1951 -- derived type. This applies to value conversions, not to view 1952 -- conversions of tagged types. 1953 1954 declare 1955 Loc : constant Source_Ptr := Sloc (N); 1956 Cond : Node_Id; 1957 Constraint : Elmt_Id; 1958 Discr_Value : Node_Id; 1959 Discr : Entity_Id; 1960 1961 New_Constraints : constant Elist_Id := New_Elmt_List; 1962 Old_Constraints : constant Elist_Id := 1963 Discriminant_Constraint (Expr_Type); 1964 1965 begin 1966 Constraint := First_Elmt (Stored_Constraint (Target_Type)); 1967 1968 while Present (Constraint) loop 1969 Discr_Value := Node (Constraint); 1970 1971 if Is_Entity_Name (Discr_Value) 1972 and then Ekind (Entity (Discr_Value)) = E_Discriminant 1973 then 1974 Discr := Corresponding_Discriminant (Entity (Discr_Value)); 1975 1976 if Present (Discr) 1977 and then Scope (Discr) = Base_Type (Expr_Type) 1978 then 1979 -- Parent is constrained by new discriminant. Obtain 1980 -- Value of original discriminant in expression. If 1981 -- the new discriminant has been used to constrain more 1982 -- than one of the stored discriminants, this will 1983 -- provide the required consistency check. 1984 1985 Append_Elmt ( 1986 Make_Selected_Component (Loc, 1987 Prefix => 1988 Duplicate_Subexpr_No_Checks 1989 (Expr, Name_Req => True), 1990 Selector_Name => 1991 Make_Identifier (Loc, Chars (Discr))), 1992 New_Constraints); 1993 1994 else 1995 -- Discriminant of more remote ancestor ??? 1996 1997 return; 1998 end if; 1999 2000 -- Derived type definition has an explicit value for 2001 -- this stored discriminant. 2002 2003 else 2004 Append_Elmt 2005 (Duplicate_Subexpr_No_Checks (Discr_Value), 2006 New_Constraints); 2007 end if; 2008 2009 Next_Elmt (Constraint); 2010 end loop; 2011 2012 -- Use the unconstrained expression type to retrieve the 2013 -- discriminants of the parent, and apply momentarily the 2014 -- discriminant constraint synthesized above. 2015 2016 Set_Discriminant_Constraint (Expr_Type, New_Constraints); 2017 Cond := Build_Discriminant_Checks (Expr, Expr_Type); 2018 Set_Discriminant_Constraint (Expr_Type, Old_Constraints); 2019 2020 Insert_Action (N, 2021 Make_Raise_Constraint_Error (Loc, 2022 Condition => Cond, 2023 Reason => CE_Discriminant_Check_Failed)); 2024 end; 2025 2026 -- For arrays, conversions are applied during expansion, to take 2027 -- into accounts changes of representation. The checks become range 2028 -- checks on the base type or length checks on the subtype, depending 2029 -- on whether the target type is unconstrained or constrained. 2030 2031 else 2032 null; 2033 end if; 2034 end Apply_Type_Conversion_Checks; 2035 2036 ---------------------------------------------- 2037 -- Apply_Universal_Integer_Attribute_Checks -- 2038 ---------------------------------------------- 2039 2040 procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is 2041 Loc : constant Source_Ptr := Sloc (N); 2042 Typ : constant Entity_Id := Etype (N); 2043 2044 begin 2045 if Inside_A_Generic then 2046 return; 2047 2048 -- Nothing to do if checks are suppressed 2049 2050 elsif Range_Checks_Suppressed (Typ) 2051 and then Overflow_Checks_Suppressed (Typ) 2052 then 2053 return; 2054 2055 -- Nothing to do if the attribute does not come from source. The 2056 -- internal attributes we generate of this type do not need checks, 2057 -- and furthermore the attempt to check them causes some circular 2058 -- elaboration orders when dealing with packed types. 2059 2060 elsif not Comes_From_Source (N) then 2061 return; 2062 2063 -- If the prefix is a selected component that depends on a discriminant 2064 -- the check may improperly expose a discriminant instead of using 2065 -- the bounds of the object itself. Set the type of the attribute to 2066 -- the base type of the context, so that a check will be imposed when 2067 -- needed (e.g. if the node appears as an index). 2068 2069 elsif Nkind (Prefix (N)) = N_Selected_Component 2070 and then Ekind (Typ) = E_Signed_Integer_Subtype 2071 and then Depends_On_Discriminant (Scalar_Range (Typ)) 2072 then 2073 Set_Etype (N, Base_Type (Typ)); 2074 2075 -- Otherwise, replace the attribute node with a type conversion 2076 -- node whose expression is the attribute, retyped to universal 2077 -- integer, and whose subtype mark is the target type. The call 2078 -- to analyze this conversion will set range and overflow checks 2079 -- as required for proper detection of an out of range value. 2080 2081 else 2082 Set_Etype (N, Universal_Integer); 2083 Set_Analyzed (N, True); 2084 2085 Rewrite (N, 2086 Make_Type_Conversion (Loc, 2087 Subtype_Mark => New_Occurrence_Of (Typ, Loc), 2088 Expression => Relocate_Node (N))); 2089 2090 Analyze_And_Resolve (N, Typ); 2091 return; 2092 end if; 2093 2094 end Apply_Universal_Integer_Attribute_Checks; 2095 2096 ------------------------------- 2097 -- Build_Discriminant_Checks -- 2098 ------------------------------- 2099 2100 function Build_Discriminant_Checks 2101 (N : Node_Id; 2102 T_Typ : Entity_Id) 2103 return Node_Id 2104 is 2105 Loc : constant Source_Ptr := Sloc (N); 2106 Cond : Node_Id; 2107 Disc : Elmt_Id; 2108 Disc_Ent : Entity_Id; 2109 Dref : Node_Id; 2110 Dval : Node_Id; 2111 2112 begin 2113 Cond := Empty; 2114 Disc := First_Elmt (Discriminant_Constraint (T_Typ)); 2115 2116 -- For a fully private type, use the discriminants of the parent type 2117 2118 if Is_Private_Type (T_Typ) 2119 and then No (Full_View (T_Typ)) 2120 then 2121 Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ))); 2122 else 2123 Disc_Ent := First_Discriminant (T_Typ); 2124 end if; 2125 2126 while Present (Disc) loop 2127 Dval := Node (Disc); 2128 2129 if Nkind (Dval) = N_Identifier 2130 and then Ekind (Entity (Dval)) = E_Discriminant 2131 then 2132 Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc); 2133 else 2134 Dval := Duplicate_Subexpr_No_Checks (Dval); 2135 end if; 2136 2137 Dref := 2138 Make_Selected_Component (Loc, 2139 Prefix => 2140 Duplicate_Subexpr_No_Checks (N, Name_Req => True), 2141 Selector_Name => 2142 Make_Identifier (Loc, Chars (Disc_Ent))); 2143 2144 Set_Is_In_Discriminant_Check (Dref); 2145 2146 Evolve_Or_Else (Cond, 2147 Make_Op_Ne (Loc, 2148 Left_Opnd => Dref, 2149 Right_Opnd => Dval)); 2150 2151 Next_Elmt (Disc); 2152 Next_Discriminant (Disc_Ent); 2153 end loop; 2154 2155 return Cond; 2156 end Build_Discriminant_Checks; 2157 2158 ----------------------------------- 2159 -- Check_Valid_Lvalue_Subscripts -- 2160 ----------------------------------- 2161 2162 procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is 2163 begin 2164 -- Skip this if range checks are suppressed 2165 2166 if Range_Checks_Suppressed (Etype (Expr)) then 2167 return; 2168 2169 -- Only do this check for expressions that come from source. We 2170 -- assume that expander generated assignments explicitly include 2171 -- any necessary checks. Note that this is not just an optimization, 2172 -- it avoids infinite recursions! 2173 2174 elsif not Comes_From_Source (Expr) then 2175 return; 2176 2177 -- For a selected component, check the prefix 2178 2179 elsif Nkind (Expr) = N_Selected_Component then 2180 Check_Valid_Lvalue_Subscripts (Prefix (Expr)); 2181 return; 2182 2183 -- Case of indexed component 2184 2185 elsif Nkind (Expr) = N_Indexed_Component then 2186 Apply_Subscript_Validity_Checks (Expr); 2187 2188 -- Prefix may itself be or contain an indexed component, and 2189 -- these subscripts need checking as well 2190 2191 Check_Valid_Lvalue_Subscripts (Prefix (Expr)); 2192 end if; 2193 end Check_Valid_Lvalue_Subscripts; 2194 2195 ---------------------------------- 2196 -- Conditional_Statements_Begin -- 2197 ---------------------------------- 2198 2199 procedure Conditional_Statements_Begin is 2200 begin 2201 Saved_Checks_TOS := Saved_Checks_TOS + 1; 2202 2203 -- If stack overflows, kill all checks, that way we know to 2204 -- simply reset the number of saved checks to zero on return. 2205 -- This should never occur in practice. 2206 2207 if Saved_Checks_TOS > Saved_Checks_Stack'Last then 2208 Kill_All_Checks; 2209 2210 -- In the normal case, we just make a new stack entry saving 2211 -- the current number of saved checks for a later restore. 2212 2213 else 2214 Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks; 2215 2216 if Debug_Flag_CC then 2217 w ("Conditional_Statements_Begin: Num_Saved_Checks = ", 2218 Num_Saved_Checks); 2219 end if; 2220 end if; 2221 end Conditional_Statements_Begin; 2222 2223 -------------------------------- 2224 -- Conditional_Statements_End -- 2225 -------------------------------- 2226 2227 procedure Conditional_Statements_End is 2228 begin 2229 pragma Assert (Saved_Checks_TOS > 0); 2230 2231 -- If the saved checks stack overflowed, then we killed all 2232 -- checks, so setting the number of saved checks back to 2233 -- zero is correct. This should never occur in practice. 2234 2235 if Saved_Checks_TOS > Saved_Checks_Stack'Last then 2236 Num_Saved_Checks := 0; 2237 2238 -- In the normal case, restore the number of saved checks 2239 -- from the top stack entry. 2240 2241 else 2242 Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS); 2243 if Debug_Flag_CC then 2244 w ("Conditional_Statements_End: Num_Saved_Checks = ", 2245 Num_Saved_Checks); 2246 end if; 2247 end if; 2248 2249 Saved_Checks_TOS := Saved_Checks_TOS - 1; 2250 end Conditional_Statements_End; 2251 2252 --------------------- 2253 -- Determine_Range -- 2254 --------------------- 2255 2256 Cache_Size : constant := 2 ** 10; 2257 type Cache_Index is range 0 .. Cache_Size - 1; 2258 -- Determine size of below cache (power of 2 is more efficient!) 2259 2260 Determine_Range_Cache_N : array (Cache_Index) of Node_Id; 2261 Determine_Range_Cache_Lo : array (Cache_Index) of Uint; 2262 Determine_Range_Cache_Hi : array (Cache_Index) of Uint; 2263 -- The above arrays are used to implement a small direct cache 2264 -- for Determine_Range calls. Because of the way Determine_Range 2265 -- recursively traces subexpressions, and because overflow checking 2266 -- calls the routine on the way up the tree, a quadratic behavior 2267 -- can otherwise be encountered in large expressions. The cache 2268 -- entry for node N is stored in the (N mod Cache_Size) entry, and 2269 -- can be validated by checking the actual node value stored there. 2270 2271 procedure Determine_Range 2272 (N : Node_Id; 2273 OK : out Boolean; 2274 Lo : out Uint; 2275 Hi : out Uint) 2276 is 2277 Typ : constant Entity_Id := Etype (N); 2278 2279 Lo_Left : Uint; 2280 Hi_Left : Uint; 2281 -- Lo and Hi bounds of left operand 2282 2283 Lo_Right : Uint; 2284 Hi_Right : Uint; 2285 -- Lo and Hi bounds of right (or only) operand 2286 2287 Bound : Node_Id; 2288 -- Temp variable used to hold a bound node 2289 2290 Hbound : Uint; 2291 -- High bound of base type of expression 2292 2293 Lor : Uint; 2294 Hir : Uint; 2295 -- Refined values for low and high bounds, after tightening 2296 2297 OK1 : Boolean; 2298 -- Used in lower level calls to indicate if call succeeded 2299 2300 Cindex : Cache_Index; 2301 -- Used to search cache 2302 2303 function OK_Operands return Boolean; 2304 -- Used for binary operators. Determines the ranges of the left and 2305 -- right operands, and if they are both OK, returns True, and puts 2306 -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left 2307 2308 ----------------- 2309 -- OK_Operands -- 2310 ----------------- 2311 2312 function OK_Operands return Boolean is 2313 begin 2314 Determine_Range (Left_Opnd (N), OK1, Lo_Left, Hi_Left); 2315 2316 if not OK1 then 2317 return False; 2318 end if; 2319 2320 Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right); 2321 return OK1; 2322 end OK_Operands; 2323 2324 -- Start of processing for Determine_Range 2325 2326 begin 2327 -- Prevent junk warnings by initializing range variables 2328 2329 Lo := No_Uint; 2330 Hi := No_Uint; 2331 Lor := No_Uint; 2332 Hir := No_Uint; 2333 2334 -- If the type is not discrete, or is undefined, then we can't 2335 -- do anything about determining the range. 2336 2337 if No (Typ) or else not Is_Discrete_Type (Typ) 2338 or else Error_Posted (N) 2339 then 2340 OK := False; 2341 return; 2342 end if; 2343 2344 -- For all other cases, we can determine the range 2345 2346 OK := True; 2347 2348 -- If value is compile time known, then the possible range is the 2349 -- one value that we know this expression definitely has! 2350 2351 if Compile_Time_Known_Value (N) then 2352 Lo := Expr_Value (N); 2353 Hi := Lo; 2354 return; 2355 end if; 2356 2357 -- Return if already in the cache 2358 2359 Cindex := Cache_Index (N mod Cache_Size); 2360 2361 if Determine_Range_Cache_N (Cindex) = N then 2362 Lo := Determine_Range_Cache_Lo (Cindex); 2363 Hi := Determine_Range_Cache_Hi (Cindex); 2364 return; 2365 end if; 2366 2367 -- Otherwise, start by finding the bounds of the type of the 2368 -- expression, the value cannot be outside this range (if it 2369 -- is, then we have an overflow situation, which is a separate 2370 -- check, we are talking here only about the expression value). 2371 2372 -- We use the actual bound unless it is dynamic, in which case 2373 -- use the corresponding base type bound if possible. If we can't 2374 -- get a bound then we figure we can't determine the range (a 2375 -- peculiar case, that perhaps cannot happen, but there is no 2376 -- point in bombing in this optimization circuit. 2377 2378 -- First the low bound 2379 2380 Bound := Type_Low_Bound (Typ); 2381 2382 if Compile_Time_Known_Value (Bound) then 2383 Lo := Expr_Value (Bound); 2384 2385 elsif Compile_Time_Known_Value (Type_Low_Bound (Base_Type (Typ))) then 2386 Lo := Expr_Value (Type_Low_Bound (Base_Type (Typ))); 2387 2388 else 2389 OK := False; 2390 return; 2391 end if; 2392 2393 -- Now the high bound 2394 2395 Bound := Type_High_Bound (Typ); 2396 2397 -- We need the high bound of the base type later on, and this should 2398 -- always be compile time known. Again, it is not clear that this 2399 -- can ever be false, but no point in bombing. 2400 2401 if Compile_Time_Known_Value (Type_High_Bound (Base_Type (Typ))) then 2402 Hbound := Expr_Value (Type_High_Bound (Base_Type (Typ))); 2403 Hi := Hbound; 2404 2405 else 2406 OK := False; 2407 return; 2408 end if; 2409 2410 -- If we have a static subtype, then that may have a tighter bound 2411 -- so use the upper bound of the subtype instead in this case. 2412 2413 if Compile_Time_Known_Value (Bound) then 2414 Hi := Expr_Value (Bound); 2415 end if; 2416 2417 -- We may be able to refine this value in certain situations. If 2418 -- refinement is possible, then Lor and Hir are set to possibly 2419 -- tighter bounds, and OK1 is set to True. 2420 2421 case Nkind (N) is 2422 2423 -- For unary plus, result is limited by range of operand 2424 2425 when N_Op_Plus => 2426 Determine_Range (Right_Opnd (N), OK1, Lor, Hir); 2427 2428 -- For unary minus, determine range of operand, and negate it 2429 2430 when N_Op_Minus => 2431 Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right); 2432 2433 if OK1 then 2434 Lor := -Hi_Right; 2435 Hir := -Lo_Right; 2436 end if; 2437 2438 -- For binary addition, get range of each operand and do the 2439 -- addition to get the result range. 2440 2441 when N_Op_Add => 2442 if OK_Operands then 2443 Lor := Lo_Left + Lo_Right; 2444 Hir := Hi_Left + Hi_Right; 2445 end if; 2446 2447 -- Division is tricky. The only case we consider is where the 2448 -- right operand is a positive constant, and in this case we 2449 -- simply divide the bounds of the left operand 2450 2451 when N_Op_Divide => 2452 if OK_Operands then 2453 if Lo_Right = Hi_Right 2454 and then Lo_Right > 0 2455 then 2456 Lor := Lo_Left / Lo_Right; 2457 Hir := Hi_Left / Lo_Right; 2458 2459 else 2460 OK1 := False; 2461 end if; 2462 end if; 2463 2464 -- For binary subtraction, get range of each operand and do 2465 -- the worst case subtraction to get the result range. 2466 2467 when N_Op_Subtract => 2468 if OK_Operands then 2469 Lor := Lo_Left - Hi_Right; 2470 Hir := Hi_Left - Lo_Right; 2471 end if; 2472 2473 -- For MOD, if right operand is a positive constant, then 2474 -- result must be in the allowable range of mod results. 2475 2476 when N_Op_Mod => 2477 if OK_Operands then 2478 if Lo_Right = Hi_Right 2479 and then Lo_Right /= 0 2480 then 2481 if Lo_Right > 0 then 2482 Lor := Uint_0; 2483 Hir := Lo_Right - 1; 2484 2485 else -- Lo_Right < 0 2486 Lor := Lo_Right + 1; 2487 Hir := Uint_0; 2488 end if; 2489 2490 else 2491 OK1 := False; 2492 end if; 2493 end if; 2494 2495 -- For REM, if right operand is a positive constant, then 2496 -- result must be in the allowable range of mod results. 2497 2498 when N_Op_Rem => 2499 if OK_Operands then 2500 if Lo_Right = Hi_Right 2501 and then Lo_Right /= 0 2502 then 2503 declare 2504 Dval : constant Uint := (abs Lo_Right) - 1; 2505 2506 begin 2507 -- The sign of the result depends on the sign of the 2508 -- dividend (but not on the sign of the divisor, hence 2509 -- the abs operation above). 2510 2511 if Lo_Left < 0 then 2512 Lor := -Dval; 2513 else 2514 Lor := Uint_0; 2515 end if; 2516 2517 if Hi_Left < 0 then 2518 Hir := Uint_0; 2519 else 2520 Hir := Dval; 2521 end if; 2522 end; 2523 2524 else 2525 OK1 := False; 2526 end if; 2527 end if; 2528 2529 -- Attribute reference cases 2530 2531 when N_Attribute_Reference => 2532 case Attribute_Name (N) is 2533 2534 -- For Pos/Val attributes, we can refine the range using the 2535 -- possible range of values of the attribute expression 2536 2537 when Name_Pos | Name_Val => 2538 Determine_Range (First (Expressions (N)), OK1, Lor, Hir); 2539 2540 -- For Length attribute, use the bounds of the corresponding 2541 -- index type to refine the range. 2542 2543 when Name_Length => 2544 declare 2545 Atyp : Entity_Id := Etype (Prefix (N)); 2546 Inum : Nat; 2547 Indx : Node_Id; 2548 2549 LL, LU : Uint; 2550 UL, UU : Uint; 2551 2552 begin 2553 if Is_Access_Type (Atyp) then 2554 Atyp := Designated_Type (Atyp); 2555 end if; 2556 2557 -- For string literal, we know exact value 2558 2559 if Ekind (Atyp) = E_String_Literal_Subtype then 2560 OK := True; 2561 Lo := String_Literal_Length (Atyp); 2562 Hi := String_Literal_Length (Atyp); 2563 return; 2564 end if; 2565 2566 -- Otherwise check for expression given 2567 2568 if No (Expressions (N)) then 2569 Inum := 1; 2570 else 2571 Inum := 2572 UI_To_Int (Expr_Value (First (Expressions (N)))); 2573 end if; 2574 2575 Indx := First_Index (Atyp); 2576 for J in 2 .. Inum loop 2577 Indx := Next_Index (Indx); 2578 end loop; 2579 2580 Determine_Range 2581 (Type_Low_Bound (Etype (Indx)), OK1, LL, LU); 2582 2583 if OK1 then 2584 Determine_Range 2585 (Type_High_Bound (Etype (Indx)), OK1, UL, UU); 2586 2587 if OK1 then 2588 2589 -- The maximum value for Length is the biggest 2590 -- possible gap between the values of the bounds. 2591 -- But of course, this value cannot be negative. 2592 2593 Hir := UI_Max (Uint_0, UU - LL); 2594 2595 -- For constrained arrays, the minimum value for 2596 -- Length is taken from the actual value of the 2597 -- bounds, since the index will be exactly of 2598 -- this subtype. 2599 2600 if Is_Constrained (Atyp) then 2601 Lor := UI_Max (Uint_0, UL - LU); 2602 2603 -- For an unconstrained array, the minimum value 2604 -- for length is always zero. 2605 2606 else 2607 Lor := Uint_0; 2608 end if; 2609 end if; 2610 end if; 2611 end; 2612 2613 -- No special handling for other attributes 2614 -- Probably more opportunities exist here ??? 2615 2616 when others => 2617 OK1 := False; 2618 2619 end case; 2620 2621 -- For type conversion from one discrete type to another, we 2622 -- can refine the range using the converted value. 2623 2624 when N_Type_Conversion => 2625 Determine_Range (Expression (N), OK1, Lor, Hir); 2626 2627 -- Nothing special to do for all other expression kinds 2628 2629 when others => 2630 OK1 := False; 2631 Lor := No_Uint; 2632 Hir := No_Uint; 2633 end case; 2634 2635 -- At this stage, if OK1 is true, then we know that the actual 2636 -- result of the computed expression is in the range Lor .. Hir. 2637 -- We can use this to restrict the possible range of results. 2638 2639 if OK1 then 2640 2641 -- If the refined value of the low bound is greater than the 2642 -- type high bound, then reset it to the more restrictive 2643 -- value. However, we do NOT do this for the case of a modular 2644 -- type where the possible upper bound on the value is above the 2645 -- base type high bound, because that means the result could wrap. 2646 2647 if Lor > Lo 2648 and then not (Is_Modular_Integer_Type (Typ) 2649 and then Hir > Hbound) 2650 then 2651 Lo := Lor; 2652 end if; 2653 2654 -- Similarly, if the refined value of the high bound is less 2655 -- than the value so far, then reset it to the more restrictive 2656 -- value. Again, we do not do this if the refined low bound is 2657 -- negative for a modular type, since this would wrap. 2658 2659 if Hir < Hi 2660 and then not (Is_Modular_Integer_Type (Typ) 2661 and then Lor < Uint_0) 2662 then 2663 Hi := Hir; 2664 end if; 2665 end if; 2666 2667 -- Set cache entry for future call and we are all done 2668 2669 Determine_Range_Cache_N (Cindex) := N; 2670 Determine_Range_Cache_Lo (Cindex) := Lo; 2671 Determine_Range_Cache_Hi (Cindex) := Hi; 2672 return; 2673 2674 -- If any exception occurs, it means that we have some bug in the compiler 2675 -- possibly triggered by a previous error, or by some unforseen peculiar 2676 -- occurrence. However, this is only an optimization attempt, so there is 2677 -- really no point in crashing the compiler. Instead we just decide, too 2678 -- bad, we can't figure out a range in this case after all. 2679 2680 exception 2681 when others => 2682 2683 -- Debug flag K disables this behavior (useful for debugging) 2684 2685 if Debug_Flag_K then 2686 raise; 2687 else 2688 OK := False; 2689 Lo := No_Uint; 2690 Hi := No_Uint; 2691 return; 2692 end if; 2693 end Determine_Range; 2694 2695 ------------------------------------ 2696 -- Discriminant_Checks_Suppressed -- 2697 ------------------------------------ 2698 2699 function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is 2700 begin 2701 if Present (E) then 2702 if Is_Unchecked_Union (E) then 2703 return True; 2704 elsif Checks_May_Be_Suppressed (E) then 2705 return Is_Check_Suppressed (E, Discriminant_Check); 2706 end if; 2707 end if; 2708 2709 return Scope_Suppress (Discriminant_Check); 2710 end Discriminant_Checks_Suppressed; 2711 2712 -------------------------------- 2713 -- Division_Checks_Suppressed -- 2714 -------------------------------- 2715 2716 function Division_Checks_Suppressed (E : Entity_Id) return Boolean is 2717 begin 2718 if Present (E) and then Checks_May_Be_Suppressed (E) then 2719 return Is_Check_Suppressed (E, Division_Check); 2720 else 2721 return Scope_Suppress (Division_Check); 2722 end if; 2723 end Division_Checks_Suppressed; 2724 2725 ----------------------------------- 2726 -- Elaboration_Checks_Suppressed -- 2727 ----------------------------------- 2728 2729 function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is 2730 begin 2731 if Present (E) then 2732 if Kill_Elaboration_Checks (E) then 2733 return True; 2734 elsif Checks_May_Be_Suppressed (E) then 2735 return Is_Check_Suppressed (E, Elaboration_Check); 2736 end if; 2737 end if; 2738 2739 return Scope_Suppress (Elaboration_Check); 2740 end Elaboration_Checks_Suppressed; 2741 2742 --------------------------- 2743 -- Enable_Overflow_Check -- 2744 --------------------------- 2745 2746 procedure Enable_Overflow_Check (N : Node_Id) is 2747 Typ : constant Entity_Id := Base_Type (Etype (N)); 2748 Chk : Nat; 2749 OK : Boolean; 2750 Ent : Entity_Id; 2751 Ofs : Uint; 2752 Lo : Uint; 2753 Hi : Uint; 2754 2755 begin 2756 if Debug_Flag_CC then 2757 w ("Enable_Overflow_Check for node ", Int (N)); 2758 Write_Str (" Source location = "); 2759 wl (Sloc (N)); 2760 pg (N); 2761 end if; 2762 2763 -- Nothing to do if the range of the result is known OK. We skip 2764 -- this for conversions, since the caller already did the check, 2765 -- and in any case the condition for deleting the check for a 2766 -- type conversion is different in any case. 2767 2768 if Nkind (N) /= N_Type_Conversion then 2769 Determine_Range (N, OK, Lo, Hi); 2770 2771 -- Note in the test below that we assume that if a bound of the 2772 -- range is equal to that of the type. That's not quite accurate 2773 -- but we do this for the following reasons: 2774 2775 -- a) The way that Determine_Range works, it will typically report 2776 -- the bounds of the value as being equal to the bounds of the 2777 -- type, because it either can't tell anything more precise, or 2778 -- does not think it is worth the effort to be more precise. 2779 2780 -- b) It is very unusual to have a situation in which this would 2781 -- generate an unnecessary overflow check (an example would be 2782 -- a subtype with a range 0 .. Integer'Last - 1 to which the 2783 -- literal value one is added. 2784 2785 -- c) The alternative is a lot of special casing in this routine 2786 -- which would partially duplicate Determine_Range processing. 2787 2788 if OK 2789 and then Lo > Expr_Value (Type_Low_Bound (Typ)) 2790 and then Hi < Expr_Value (Type_High_Bound (Typ)) 2791 then 2792 if Debug_Flag_CC then 2793 w ("No overflow check required"); 2794 end if; 2795 2796 return; 2797 end if; 2798 end if; 2799 2800 -- If not in optimizing mode, set flag and we are done. We are also 2801 -- done (and just set the flag) if the type is not a discrete type, 2802 -- since it is not worth the effort to eliminate checks for other 2803 -- than discrete types. In addition, we take this same path if we 2804 -- have stored the maximum number of checks possible already (a 2805 -- very unlikely situation, but we do not want to blow up!) 2806 2807 if Optimization_Level = 0 2808 or else not Is_Discrete_Type (Etype (N)) 2809 or else Num_Saved_Checks = Saved_Checks'Last 2810 then 2811 Set_Do_Overflow_Check (N, True); 2812 2813 if Debug_Flag_CC then 2814 w ("Optimization off"); 2815 end if; 2816 2817 return; 2818 end if; 2819 2820 -- Otherwise evaluate and check the expression 2821 2822 Find_Check 2823 (Expr => N, 2824 Check_Type => 'O', 2825 Target_Type => Empty, 2826 Entry_OK => OK, 2827 Check_Num => Chk, 2828 Ent => Ent, 2829 Ofs => Ofs); 2830 2831 if Debug_Flag_CC then 2832 w ("Called Find_Check"); 2833 w (" OK = ", OK); 2834 2835 if OK then 2836 w (" Check_Num = ", Chk); 2837 w (" Ent = ", Int (Ent)); 2838 Write_Str (" Ofs = "); 2839 pid (Ofs); 2840 end if; 2841 end if; 2842 2843 -- If check is not of form to optimize, then set flag and we are done 2844 2845 if not OK then 2846 Set_Do_Overflow_Check (N, True); 2847 return; 2848 end if; 2849 2850 -- If check is already performed, then return without setting flag 2851 2852 if Chk /= 0 then 2853 if Debug_Flag_CC then 2854 w ("Check suppressed!"); 2855 end if; 2856 2857 return; 2858 end if; 2859 2860 -- Here we will make a new entry for the new check 2861 2862 Set_Do_Overflow_Check (N, True); 2863 Num_Saved_Checks := Num_Saved_Checks + 1; 2864 Saved_Checks (Num_Saved_Checks) := 2865 (Killed => False, 2866 Entity => Ent, 2867 Offset => Ofs, 2868 Check_Type => 'O', 2869 Target_Type => Empty); 2870 2871 if Debug_Flag_CC then 2872 w ("Make new entry, check number = ", Num_Saved_Checks); 2873 w (" Entity = ", Int (Ent)); 2874 Write_Str (" Offset = "); 2875 pid (Ofs); 2876 w (" Check_Type = O"); 2877 w (" Target_Type = Empty"); 2878 end if; 2879 2880 -- If we get an exception, then something went wrong, probably because 2881 -- of an error in the structure of the tree due to an incorrect program. 2882 -- Or it may be a bug in the optimization circuit. In either case the 2883 -- safest thing is simply to set the check flag unconditionally. 2884 2885 exception 2886 when others => 2887 Set_Do_Overflow_Check (N, True); 2888 2889 if Debug_Flag_CC then 2890 w (" exception occurred, overflow flag set"); 2891 end if; 2892 2893 return; 2894 end Enable_Overflow_Check; 2895 2896 ------------------------ 2897 -- Enable_Range_Check -- 2898 ------------------------ 2899 2900 procedure Enable_Range_Check (N : Node_Id) is 2901 Chk : Nat; 2902 OK : Boolean; 2903 Ent : Entity_Id; 2904 Ofs : Uint; 2905 Ttyp : Entity_Id; 2906 P : Node_Id; 2907 2908 begin 2909 -- Return if unchecked type conversion with range check killed. 2910 -- In this case we never set the flag (that's what Kill_Range_Check 2911 -- is all about!) 2912 2913 if Nkind (N) = N_Unchecked_Type_Conversion 2914 and then Kill_Range_Check (N) 2915 then 2916 return; 2917 end if; 2918 2919 -- Debug trace output 2920 2921 if Debug_Flag_CC then 2922 w ("Enable_Range_Check for node ", Int (N)); 2923 Write_Str (" Source location = "); 2924 wl (Sloc (N)); 2925 pg (N); 2926 end if; 2927 2928 -- If not in optimizing mode, set flag and we are done. We are also 2929 -- done (and just set the flag) if the type is not a discrete type, 2930 -- since it is not worth the effort to eliminate checks for other 2931 -- than discrete types. In addition, we take this same path if we 2932 -- have stored the maximum number of checks possible already (a 2933 -- very unlikely situation, but we do not want to blow up!) 2934 2935 if Optimization_Level = 0 2936 or else No (Etype (N)) 2937 or else not Is_Discrete_Type (Etype (N)) 2938 or else Num_Saved_Checks = Saved_Checks'Last 2939 then 2940 Set_Do_Range_Check (N, True); 2941 2942 if Debug_Flag_CC then 2943 w ("Optimization off"); 2944 end if; 2945 2946 return; 2947 end if; 2948 2949 -- Otherwise find out the target type 2950 2951 P := Parent (N); 2952 2953 -- For assignment, use left side subtype 2954 2955 if Nkind (P) = N_Assignment_Statement 2956 and then Expression (P) = N 2957 then 2958 Ttyp := Etype (Name (P)); 2959 2960 -- For indexed component, use subscript subtype 2961 2962 elsif Nkind (P) = N_Indexed_Component then 2963 declare 2964 Atyp : Entity_Id; 2965 Indx : Node_Id; 2966 Subs : Node_Id; 2967 2968 begin 2969 Atyp := Etype (Prefix (P)); 2970 2971 if Is_Access_Type (Atyp) then 2972 Atyp := Designated_Type (Atyp); 2973 end if; 2974 2975 Indx := First_Index (Atyp); 2976 Subs := First (Expressions (P)); 2977 loop 2978 if Subs = N then 2979 Ttyp := Etype (Indx); 2980 exit; 2981 end if; 2982 2983 Next_Index (Indx); 2984 Next (Subs); 2985 end loop; 2986 end; 2987 2988 -- For now, ignore all other cases, they are not so interesting 2989 2990 else 2991 if Debug_Flag_CC then 2992 w (" target type not found, flag set"); 2993 end if; 2994 2995 Set_Do_Range_Check (N, True); 2996 return; 2997 end if; 2998 2999 -- Evaluate and check the expression 3000 3001 Find_Check 3002 (Expr => N, 3003 Check_Type => 'R', 3004 Target_Type => Ttyp, 3005 Entry_OK => OK, 3006 Check_Num => Chk, 3007 Ent => Ent, 3008 Ofs => Ofs); 3009 3010 if Debug_Flag_CC then 3011 w ("Called Find_Check"); 3012 w ("Target_Typ = ", Int (Ttyp)); 3013 w (" OK = ", OK); 3014 3015 if OK then 3016 w (" Check_Num = ", Chk); 3017 w (" Ent = ", Int (Ent)); 3018 Write_Str (" Ofs = "); 3019 pid (Ofs); 3020 end if; 3021 end if; 3022 3023 -- If check is not of form to optimize, then set flag and we are done 3024 3025 if not OK then 3026 if Debug_Flag_CC then 3027 w (" expression not of optimizable type, flag set"); 3028 end if; 3029 3030 Set_Do_Range_Check (N, True); 3031 return; 3032 end if; 3033 3034 -- If check is already performed, then return without setting flag 3035 3036 if Chk /= 0 then 3037 if Debug_Flag_CC then 3038 w ("Check suppressed!"); 3039 end if; 3040 3041 return; 3042 end if; 3043 3044 -- Here we will make a new entry for the new check 3045 3046 Set_Do_Range_Check (N, True); 3047 Num_Saved_Checks := Num_Saved_Checks + 1; 3048 Saved_Checks (Num_Saved_Checks) := 3049 (Killed => False, 3050 Entity => Ent, 3051 Offset => Ofs, 3052 Check_Type => 'R', 3053 Target_Type => Ttyp); 3054 3055 if Debug_Flag_CC then 3056 w ("Make new entry, check number = ", Num_Saved_Checks); 3057 w (" Entity = ", Int (Ent)); 3058 Write_Str (" Offset = "); 3059 pid (Ofs); 3060 w (" Check_Type = R"); 3061 w (" Target_Type = ", Int (Ttyp)); 3062 pg (Ttyp); 3063 end if; 3064 3065 -- If we get an exception, then something went wrong, probably because 3066 -- of an error in the structure of the tree due to an incorrect program. 3067 -- Or it may be a bug in the optimization circuit. In either case the 3068 -- safest thing is simply to set the check flag unconditionally. 3069 3070 exception 3071 when others => 3072 Set_Do_Range_Check (N, True); 3073 3074 if Debug_Flag_CC then 3075 w (" exception occurred, range flag set"); 3076 end if; 3077 3078 return; 3079 end Enable_Range_Check; 3080 3081 ------------------ 3082 -- Ensure_Valid -- 3083 ------------------ 3084 3085 procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False) is 3086 Typ : constant Entity_Id := Etype (Expr); 3087 3088 begin 3089 -- Ignore call if we are not doing any validity checking 3090 3091 if not Validity_Checks_On then 3092 return; 3093 3094 -- Ignore call if range checks suppressed on entity in question 3095 3096 elsif Is_Entity_Name (Expr) 3097 and then Range_Checks_Suppressed (Entity (Expr)) 3098 then 3099 return; 3100 3101 -- No check required if expression is from the expander, we assume 3102 -- the expander will generate whatever checks are needed. Note that 3103 -- this is not just an optimization, it avoids infinite recursions! 3104 3105 -- Unchecked conversions must be checked, unless they are initialized 3106 -- scalar values, as in a component assignment in an init proc. 3107 3108 -- In addition, we force a check if Force_Validity_Checks is set 3109 3110 elsif not Comes_From_Source (Expr) 3111 and then not Force_Validity_Checks 3112 and then (Nkind (Expr) /= N_Unchecked_Type_Conversion 3113 or else Kill_Range_Check (Expr)) 3114 then 3115 return; 3116 3117 -- No check required if expression is known to have valid value 3118 3119 elsif Expr_Known_Valid (Expr) then 3120 return; 3121 3122 -- No check required if checks off 3123 3124 elsif Range_Checks_Suppressed (Typ) then 3125 return; 3126 3127 -- Ignore case of enumeration with holes where the flag is set not 3128 -- to worry about holes, since no special validity check is needed 3129 3130 elsif Is_Enumeration_Type (Typ) 3131 and then Has_Non_Standard_Rep (Typ) 3132 and then Holes_OK 3133 then 3134 return; 3135 3136 -- No check required on the left-hand side of an assignment. 3137 3138 elsif Nkind (Parent (Expr)) = N_Assignment_Statement 3139 and then Expr = Name (Parent (Expr)) 3140 then 3141 return; 3142 3143 -- An annoying special case. If this is an out parameter of a scalar 3144 -- type, then the value is not going to be accessed, therefore it is 3145 -- inappropriate to do any validity check at the call site. 3146 3147 else 3148 -- Only need to worry about scalar types 3149 3150 if Is_Scalar_Type (Typ) then 3151 declare 3152 P : Node_Id; 3153 N : Node_Id; 3154 E : Entity_Id; 3155 F : Entity_Id; 3156 A : Node_Id; 3157 L : List_Id; 3158 3159 begin 3160 -- Find actual argument (which may be a parameter association) 3161 -- and the parent of the actual argument (the call statement) 3162 3163 N := Expr; 3164 P := Parent (Expr); 3165 3166 if Nkind (P) = N_Parameter_Association then 3167 N := P; 3168 P := Parent (N); 3169 end if; 3170 3171 -- Only need to worry if we are argument of a procedure 3172 -- call since functions don't have out parameters. If this 3173 -- is an indirect or dispatching call, get signature from 3174 -- the subprogram type. 3175 3176 if Nkind (P) = N_Procedure_Call_Statement then 3177 L := Parameter_Associations (P); 3178 3179 if Is_Entity_Name (Name (P)) then 3180 E := Entity (Name (P)); 3181 else 3182 pragma Assert (Nkind (Name (P)) = N_Explicit_Dereference); 3183 E := Etype (Name (P)); 3184 end if; 3185 3186 -- Only need to worry if there are indeed actuals, and 3187 -- if this could be a procedure call, otherwise we cannot 3188 -- get a match (either we are not an argument, or the 3189 -- mode of the formal is not OUT). This test also filters 3190 -- out the generic case. 3191 3192 if Is_Non_Empty_List (L) 3193 and then Is_Subprogram (E) 3194 then 3195 -- This is the loop through parameters, looking to 3196 -- see if there is an OUT parameter for which we are 3197 -- the argument. 3198 3199 F := First_Formal (E); 3200 A := First (L); 3201 3202 while Present (F) loop 3203 if Ekind (F) = E_Out_Parameter and then A = N then 3204 return; 3205 end if; 3206 3207 Next_Formal (F); 3208 Next (A); 3209 end loop; 3210 end if; 3211 end if; 3212 end; 3213 end if; 3214 end if; 3215 3216 -- If we fall through, a validity check is required. Note that it would 3217 -- not be good to set Do_Range_Check, even in contexts where this is 3218 -- permissible, since this flag causes checking against the target type, 3219 -- not the source type in contexts such as assignments 3220 3221 Insert_Valid_Check (Expr); 3222 end Ensure_Valid; 3223 3224 ---------------------- 3225 -- Expr_Known_Valid -- 3226 ---------------------- 3227 3228 function Expr_Known_Valid (Expr : Node_Id) return Boolean is 3229 Typ : constant Entity_Id := Etype (Expr); 3230 3231 begin 3232 -- Non-scalar types are always consdered valid, since they never 3233 -- give rise to the issues of erroneous or bounded error behavior 3234 -- that are the concern. In formal reference manual terms the 3235 -- notion of validity only applies to scalar types. 3236 3237 if not Is_Scalar_Type (Typ) then 3238 return True; 3239 3240 -- If no validity checking, then everything is considered valid 3241 3242 elsif not Validity_Checks_On then 3243 return True; 3244 3245 -- Floating-point types are considered valid unless floating-point 3246 -- validity checks have been specifically turned on. 3247 3248 elsif Is_Floating_Point_Type (Typ) 3249 and then not Validity_Check_Floating_Point 3250 then 3251 return True; 3252 3253 -- If the expression is the value of an object that is known to 3254 -- be valid, then clearly the expression value itself is valid. 3255 3256 elsif Is_Entity_Name (Expr) 3257 and then Is_Known_Valid (Entity (Expr)) 3258 then 3259 return True; 3260 3261 -- If the type is one for which all values are known valid, then 3262 -- we are sure that the value is valid except in the slightly odd 3263 -- case where the expression is a reference to a variable whose size 3264 -- has been explicitly set to a value greater than the object size. 3265 3266 elsif Is_Known_Valid (Typ) then 3267 if Is_Entity_Name (Expr) 3268 and then Ekind (Entity (Expr)) = E_Variable 3269 and then Esize (Entity (Expr)) > Esize (Typ) 3270 then 3271 return False; 3272 else 3273 return True; 3274 end if; 3275 3276 -- Integer and character literals always have valid values, where 3277 -- appropriate these will be range checked in any case. 3278 3279 elsif Nkind (Expr) = N_Integer_Literal 3280 or else 3281 Nkind (Expr) = N_Character_Literal 3282 then 3283 return True; 3284 3285 -- If we have a type conversion or a qualification of a known valid 3286 -- value, then the result will always be valid. 3287 3288 elsif Nkind (Expr) = N_Type_Conversion 3289 or else 3290 Nkind (Expr) = N_Qualified_Expression 3291 then 3292 return Expr_Known_Valid (Expression (Expr)); 3293 3294 -- The result of any function call or operator is always considered 3295 -- valid, since we assume the necessary checks are done by the call. 3296 3297 elsif Nkind (Expr) in N_Binary_Op 3298 or else 3299 Nkind (Expr) in N_Unary_Op 3300 or else 3301 Nkind (Expr) = N_Function_Call 3302 then 3303 return True; 3304 3305 -- For all other cases, we do not know the expression is valid 3306 3307 else 3308 return False; 3309 end if; 3310 end Expr_Known_Valid; 3311 3312 ---------------- 3313 -- Find_Check -- 3314 ---------------- 3315 3316 procedure Find_Check 3317 (Expr : Node_Id; 3318 Check_Type : Character; 3319 Target_Type : Entity_Id; 3320 Entry_OK : out Boolean; 3321 Check_Num : out Nat; 3322 Ent : out Entity_Id; 3323 Ofs : out Uint) 3324 is 3325 function Within_Range_Of 3326 (Target_Type : Entity_Id; 3327 Check_Type : Entity_Id) 3328 return Boolean; 3329 -- Given a requirement for checking a range against Target_Type, and 3330 -- and a range Check_Type against which a check has already been made, 3331 -- determines if the check against check type is sufficient to ensure 3332 -- that no check against Target_Type is required. 3333 3334 --------------------- 3335 -- Within_Range_Of -- 3336 --------------------- 3337 3338 function Within_Range_Of 3339 (Target_Type : Entity_Id; 3340 Check_Type : Entity_Id) 3341 return Boolean 3342 is 3343 begin 3344 if Target_Type = Check_Type then 3345 return True; 3346 3347 else 3348 declare 3349 Tlo : constant Node_Id := Type_Low_Bound (Target_Type); 3350 Thi : constant Node_Id := Type_High_Bound (Target_Type); 3351 Clo : constant Node_Id := Type_Low_Bound (Check_Type); 3352 Chi : constant Node_Id := Type_High_Bound (Check_Type); 3353 3354 begin 3355 if (Tlo = Clo 3356 or else (Compile_Time_Known_Value (Tlo) 3357 and then 3358 Compile_Time_Known_Value (Clo) 3359 and then 3360 Expr_Value (Clo) >= Expr_Value (Tlo))) 3361 and then 3362 (Thi = Chi 3363 or else (Compile_Time_Known_Value (Thi) 3364 and then 3365 Compile_Time_Known_Value (Chi) 3366 and then 3367 Expr_Value (Chi) <= Expr_Value (Clo))) 3368 then 3369 return True; 3370 else 3371 return False; 3372 end if; 3373 end; 3374 end if; 3375 end Within_Range_Of; 3376 3377 -- Start of processing for Find_Check 3378 3379 begin 3380 -- Establish default, to avoid warnings from GCC. 3381 3382 Check_Num := 0; 3383 3384 -- Case of expression is simple entity reference 3385 3386 if Is_Entity_Name (Expr) then 3387 Ent := Entity (Expr); 3388 Ofs := Uint_0; 3389 3390 -- Case of expression is entity + known constant 3391 3392 elsif Nkind (Expr) = N_Op_Add 3393 and then Compile_Time_Known_Value (Right_Opnd (Expr)) 3394 and then Is_Entity_Name (Left_Opnd (Expr)) 3395 then 3396 Ent := Entity (Left_Opnd (Expr)); 3397 Ofs := Expr_Value (Right_Opnd (Expr)); 3398 3399 -- Case of expression is entity - known constant 3400 3401 elsif Nkind (Expr) = N_Op_Subtract 3402 and then Compile_Time_Known_Value (Right_Opnd (Expr)) 3403 and then Is_Entity_Name (Left_Opnd (Expr)) 3404 then 3405 Ent := Entity (Left_Opnd (Expr)); 3406 Ofs := UI_Negate (Expr_Value (Right_Opnd (Expr))); 3407 3408 -- Any other expression is not of the right form 3409 3410 else 3411 Ent := Empty; 3412 Ofs := Uint_0; 3413 Entry_OK := False; 3414 return; 3415 end if; 3416 3417 -- Come here with expression of appropriate form, check if 3418 -- entity is an appropriate one for our purposes. 3419 3420 if (Ekind (Ent) = E_Variable 3421 or else 3422 Ekind (Ent) = E_Constant 3423 or else 3424 Ekind (Ent) = E_Loop_Parameter 3425 or else 3426 Ekind (Ent) = E_In_Parameter) 3427 and then not Is_Library_Level_Entity (Ent) 3428 then 3429 Entry_OK := True; 3430 else 3431 Entry_OK := False; 3432 return; 3433 end if; 3434 3435 -- See if there is matching check already 3436 3437 for J in reverse 1 .. Num_Saved_Checks loop 3438 declare 3439 SC : Saved_Check renames Saved_Checks (J); 3440 3441 begin 3442 if SC.Killed = False 3443 and then SC.Entity = Ent 3444 and then SC.Offset = Ofs 3445 and then SC.Check_Type = Check_Type 3446 and then Within_Range_Of (Target_Type, SC.Target_Type) 3447 then 3448 Check_Num := J; 3449 return; 3450 end if; 3451 end; 3452 end loop; 3453 3454 -- If we fall through entry was not found 3455 3456 Check_Num := 0; 3457 return; 3458 end Find_Check; 3459 3460 --------------------------------- 3461 -- Generate_Discriminant_Check -- 3462 --------------------------------- 3463 3464 -- Note: the code for this procedure is derived from the 3465 -- emit_discriminant_check routine a-trans.c v1.659. 3466 3467 procedure Generate_Discriminant_Check (N : Node_Id) is 3468 Loc : constant Source_Ptr := Sloc (N); 3469 Pref : constant Node_Id := Prefix (N); 3470 Sel : constant Node_Id := Selector_Name (N); 3471 3472 Orig_Comp : constant Entity_Id := 3473 Original_Record_Component (Entity (Sel)); 3474 -- The original component to be checked 3475 3476 Discr_Fct : constant Entity_Id := 3477 Discriminant_Checking_Func (Orig_Comp); 3478 -- The discriminant checking function 3479 3480 Discr : Entity_Id; 3481 -- One discriminant to be checked in the type 3482 3483 Real_Discr : Entity_Id; 3484 -- Actual discriminant in the call 3485 3486 Pref_Type : Entity_Id; 3487 -- Type of relevant prefix (ignoring private/access stuff) 3488 3489 Args : List_Id; 3490 -- List of arguments for function call 3491 3492 Formal : Entity_Id; 3493 -- Keep track of the formal corresponding to the actual we build 3494 -- for each discriminant, in order to be able to perform the 3495 -- necessary type conversions. 3496 3497 Scomp : Node_Id; 3498 -- Selected component reference for checking function argument 3499 3500 begin 3501 Pref_Type := Etype (Pref); 3502 3503 -- Force evaluation of the prefix, so that it does not get evaluated 3504 -- twice (once for the check, once for the actual reference). Such a 3505 -- double evaluation is always a potential source of inefficiency, 3506 -- and is functionally incorrect in the volatile case, or when the 3507 -- prefix may have side-effects. An entity or a component of an 3508 -- entity requires no evaluation. 3509 3510 if Is_Entity_Name (Pref) then 3511 if Treat_As_Volatile (Entity (Pref)) then 3512 Force_Evaluation (Pref, Name_Req => True); 3513 end if; 3514 3515 elsif Treat_As_Volatile (Etype (Pref)) then 3516 Force_Evaluation (Pref, Name_Req => True); 3517 3518 elsif Nkind (Pref) = N_Selected_Component 3519 and then Is_Entity_Name (Prefix (Pref)) 3520 then 3521 null; 3522 3523 else 3524 Force_Evaluation (Pref, Name_Req => True); 3525 end if; 3526 3527 -- For a tagged type, use the scope of the original component to 3528 -- obtain the type, because ??? 3529 3530 if Is_Tagged_Type (Scope (Orig_Comp)) then 3531 Pref_Type := Scope (Orig_Comp); 3532 3533 -- For an untagged derived type, use the discriminants of the 3534 -- parent which have been renamed in the derivation, possibly 3535 -- by a one-to-many discriminant constraint. 3536 -- For non-tagged type, initially get the Etype of the prefix 3537 3538 else 3539 if Is_Derived_Type (Pref_Type) 3540 and then Number_Discriminants (Pref_Type) /= 3541 Number_Discriminants (Etype (Base_Type (Pref_Type))) 3542 then 3543 Pref_Type := Etype (Base_Type (Pref_Type)); 3544 end if; 3545 end if; 3546 3547 -- We definitely should have a checking function, This routine should 3548 -- not be called if no discriminant checking function is present. 3549 3550 pragma Assert (Present (Discr_Fct)); 3551 3552 -- Create the list of the actual parameters for the call. This list 3553 -- is the list of the discriminant fields of the record expression to 3554 -- be discriminant checked. 3555 3556 Args := New_List; 3557 Formal := First_Formal (Discr_Fct); 3558 Discr := First_Discriminant (Pref_Type); 3559 while Present (Discr) loop 3560 3561 -- If we have a corresponding discriminant field, and a parent 3562 -- subtype is present, then we want to use the corresponding 3563 -- discriminant since this is the one with the useful value. 3564 3565 if Present (Corresponding_Discriminant (Discr)) 3566 and then Ekind (Pref_Type) = E_Record_Type 3567 and then Present (Parent_Subtype (Pref_Type)) 3568 then 3569 Real_Discr := Corresponding_Discriminant (Discr); 3570 else 3571 Real_Discr := Discr; 3572 end if; 3573 3574 -- Construct the reference to the discriminant 3575 3576 Scomp := 3577 Make_Selected_Component (Loc, 3578 Prefix => 3579 Unchecked_Convert_To (Pref_Type, 3580 Duplicate_Subexpr (Pref)), 3581 Selector_Name => New_Occurrence_Of (Real_Discr, Loc)); 3582 3583 -- Manually analyze and resolve this selected component. We really 3584 -- want it just as it appears above, and do not want the expander 3585 -- playing discriminal games etc with this reference. Then we 3586 -- append the argument to the list we are gathering. 3587 3588 Set_Etype (Scomp, Etype (Real_Discr)); 3589 Set_Analyzed (Scomp, True); 3590 Append_To (Args, Convert_To (Etype (Formal), Scomp)); 3591 3592 Next_Formal_With_Extras (Formal); 3593 Next_Discriminant (Discr); 3594 end loop; 3595 3596 -- Now build and insert the call 3597 3598 Insert_Action (N, 3599 Make_Raise_Constraint_Error (Loc, 3600 Condition => 3601 Make_Function_Call (Loc, 3602 Name => New_Occurrence_Of (Discr_Fct, Loc), 3603 Parameter_Associations => Args), 3604 Reason => CE_Discriminant_Check_Failed)); 3605 end Generate_Discriminant_Check; 3606 3607 ---------------------------- 3608 -- Generate_Index_Checks -- 3609 ---------------------------- 3610 3611 procedure Generate_Index_Checks (N : Node_Id) is 3612 Loc : constant Source_Ptr := Sloc (N); 3613 A : constant Node_Id := Prefix (N); 3614 Sub : Node_Id; 3615 Ind : Nat; 3616 Num : List_Id; 3617 3618 begin 3619 Sub := First (Expressions (N)); 3620 Ind := 1; 3621 while Present (Sub) loop 3622 if Do_Range_Check (Sub) then 3623 Set_Do_Range_Check (Sub, False); 3624 3625 -- Force evaluation except for the case of a simple name of 3626 -- a non-volatile entity. 3627 3628 if not Is_Entity_Name (Sub) 3629 or else Treat_As_Volatile (Entity (Sub)) 3630 then 3631 Force_Evaluation (Sub); 3632 end if; 3633 3634 -- Generate a raise of constraint error with the appropriate 3635 -- reason and a condition of the form: 3636 3637 -- Base_Type(Sub) not in array'range (subscript) 3638 3639 -- Note that the reason we generate the conversion to the 3640 -- base type here is that we definitely want the range check 3641 -- to take place, even if it looks like the subtype is OK. 3642 -- Optimization considerations that allow us to omit the 3643 -- check have already been taken into account in the setting 3644 -- of the Do_Range_Check flag earlier on. 3645 3646 if Ind = 1 then 3647 Num := No_List; 3648 else 3649 Num := New_List (Make_Integer_Literal (Loc, Ind)); 3650 end if; 3651 3652 Insert_Action (N, 3653 Make_Raise_Constraint_Error (Loc, 3654 Condition => 3655 Make_Not_In (Loc, 3656 Left_Opnd => 3657 Convert_To (Base_Type (Etype (Sub)), 3658 Duplicate_Subexpr_Move_Checks (Sub)), 3659 Right_Opnd => 3660 Make_Attribute_Reference (Loc, 3661 Prefix => Duplicate_Subexpr_Move_Checks (A), 3662 Attribute_Name => Name_Range, 3663 Expressions => Num)), 3664 Reason => CE_Index_Check_Failed)); 3665 end if; 3666 3667 Ind := Ind + 1; 3668 Next (Sub); 3669 end loop; 3670 end Generate_Index_Checks; 3671 3672 -------------------------- 3673 -- Generate_Range_Check -- 3674 -------------------------- 3675 3676 procedure Generate_Range_Check 3677 (N : Node_Id; 3678 Target_Type : Entity_Id; 3679 Reason : RT_Exception_Code) 3680 is 3681 Loc : constant Source_Ptr := Sloc (N); 3682 Source_Type : constant Entity_Id := Etype (N); 3683 Source_Base_Type : constant Entity_Id := Base_Type (Source_Type); 3684 Target_Base_Type : constant Entity_Id := Base_Type (Target_Type); 3685 3686 begin 3687 -- First special case, if the source type is already within the 3688 -- range of the target type, then no check is needed (probably we 3689 -- should have stopped Do_Range_Check from being set in the first 3690 -- place, but better late than later in preventing junk code! 3691 3692 -- We do NOT apply this if the source node is a literal, since in 3693 -- this case the literal has already been labeled as having the 3694 -- subtype of the target. 3695 3696 if In_Subrange_Of (Source_Type, Target_Type) 3697 and then not 3698 (Nkind (N) = N_Integer_Literal 3699 or else 3700 Nkind (N) = N_Real_Literal 3701 or else 3702 Nkind (N) = N_Character_Literal 3703 or else 3704 (Is_Entity_Name (N) 3705 and then Ekind (Entity (N)) = E_Enumeration_Literal)) 3706 then 3707 return; 3708 end if; 3709 3710 -- We need a check, so force evaluation of the node, so that it does 3711 -- not get evaluated twice (once for the check, once for the actual 3712 -- reference). Such a double evaluation is always a potential source 3713 -- of inefficiency, and is functionally incorrect in the volatile case. 3714 3715 if not Is_Entity_Name (N) 3716 or else Treat_As_Volatile (Entity (N)) 3717 then 3718 Force_Evaluation (N); 3719 end if; 3720 3721 -- The easiest case is when Source_Base_Type and Target_Base_Type 3722 -- are the same since in this case we can simply do a direct 3723 -- check of the value of N against the bounds of Target_Type. 3724 3725 -- [constraint_error when N not in Target_Type] 3726 3727 -- Note: this is by far the most common case, for example all cases of 3728 -- checks on the RHS of assignments are in this category, but not all 3729 -- cases are like this. Notably conversions can involve two types. 3730 3731 if Source_Base_Type = Target_Base_Type then 3732 Insert_Action (N, 3733 Make_Raise_Constraint_Error (Loc, 3734 Condition => 3735 Make_Not_In (Loc, 3736 Left_Opnd => Duplicate_Subexpr (N), 3737 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)), 3738 Reason => Reason)); 3739 3740 -- Next test for the case where the target type is within the bounds 3741 -- of the base type of the source type, since in this case we can 3742 -- simply convert these bounds to the base type of T to do the test. 3743 3744 -- [constraint_error when N not in 3745 -- Source_Base_Type (Target_Type'First) 3746 -- .. 3747 -- Source_Base_Type(Target_Type'Last))] 3748 3749 -- The conversions will always work and need no check. 3750 3751 elsif In_Subrange_Of (Target_Type, Source_Base_Type) then 3752 Insert_Action (N, 3753 Make_Raise_Constraint_Error (Loc, 3754 Condition => 3755 Make_Not_In (Loc, 3756 Left_Opnd => Duplicate_Subexpr (N), 3757 3758 Right_Opnd => 3759 Make_Range (Loc, 3760 Low_Bound => 3761 Convert_To (Source_Base_Type, 3762 Make_Attribute_Reference (Loc, 3763 Prefix => 3764 New_Occurrence_Of (Target_Type, Loc), 3765 Attribute_Name => Name_First)), 3766 3767 High_Bound => 3768 Convert_To (Source_Base_Type, 3769 Make_Attribute_Reference (Loc, 3770 Prefix => 3771 New_Occurrence_Of (Target_Type, Loc), 3772 Attribute_Name => Name_Last)))), 3773 Reason => Reason)); 3774 3775 -- Note that at this stage we now that the Target_Base_Type is 3776 -- not in the range of the Source_Base_Type (since even the 3777 -- Target_Type itself is not in this range). It could still be 3778 -- the case that the Source_Type is in range of the target base 3779 -- type, since we have not checked that case. 3780 3781 -- If that is the case, we can freely convert the source to the 3782 -- target, and then test the target result against the bounds. 3783 3784 elsif In_Subrange_Of (Source_Type, Target_Base_Type) then 3785 3786 -- We make a temporary to hold the value of the converted 3787 -- value (converted to the base type), and then we will 3788 -- do the test against this temporary. 3789 3790 -- Tnn : constant Target_Base_Type := Target_Base_Type (N); 3791 -- [constraint_error when Tnn not in Target_Type] 3792 3793 -- Then the conversion itself is replaced by an occurrence of Tnn 3794 3795 declare 3796 Tnn : constant Entity_Id := 3797 Make_Defining_Identifier (Loc, 3798 Chars => New_Internal_Name ('T')); 3799 3800 begin 3801 Insert_Actions (N, New_List ( 3802 Make_Object_Declaration (Loc, 3803 Defining_Identifier => Tnn, 3804 Object_Definition => 3805 New_Occurrence_Of (Target_Base_Type, Loc), 3806 Constant_Present => True, 3807 Expression => 3808 Make_Type_Conversion (Loc, 3809 Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc), 3810 Expression => Duplicate_Subexpr (N))), 3811 3812 Make_Raise_Constraint_Error (Loc, 3813 Condition => 3814 Make_Not_In (Loc, 3815 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 3816 Right_Opnd => New_Occurrence_Of (Target_Type, Loc)), 3817 3818 Reason => Reason))); 3819 3820 Rewrite (N, New_Occurrence_Of (Tnn, Loc)); 3821 end; 3822 3823 -- At this stage, we know that we have two scalar types, which are 3824 -- directly convertible, and where neither scalar type has a base 3825 -- range that is in the range of the other scalar type. 3826 3827 -- The only way this can happen is with a signed and unsigned type. 3828 -- So test for these two cases: 3829 3830 else 3831 -- Case of the source is unsigned and the target is signed 3832 3833 if Is_Unsigned_Type (Source_Base_Type) 3834 and then not Is_Unsigned_Type (Target_Base_Type) 3835 then 3836 -- If the source is unsigned and the target is signed, then we 3837 -- know that the source is not shorter than the target (otherwise 3838 -- the source base type would be in the target base type range). 3839 3840 -- In other words, the unsigned type is either the same size 3841 -- as the target, or it is larger. It cannot be smaller. 3842 3843 pragma Assert 3844 (Esize (Source_Base_Type) >= Esize (Target_Base_Type)); 3845 3846 -- We only need to check the low bound if the low bound of the 3847 -- target type is non-negative. If the low bound of the target 3848 -- type is negative, then we know that we will fit fine. 3849 3850 -- If the high bound of the target type is negative, then we 3851 -- know we have a constraint error, since we can't possibly 3852 -- have a negative source. 3853 3854 -- With these two checks out of the way, we can do the check 3855 -- using the source type safely 3856 3857 -- This is definitely the most annoying case! 3858 3859 -- [constraint_error 3860 -- when (Target_Type'First >= 0 3861 -- and then 3862 -- N < Source_Base_Type (Target_Type'First)) 3863 -- or else Target_Type'Last < 0 3864 -- or else N > Source_Base_Type (Target_Type'Last)]; 3865 3866 -- We turn off all checks since we know that the conversions 3867 -- will work fine, given the guards for negative values. 3868 3869 Insert_Action (N, 3870 Make_Raise_Constraint_Error (Loc, 3871 Condition => 3872 Make_Or_Else (Loc, 3873 Make_Or_Else (Loc, 3874 Left_Opnd => 3875 Make_And_Then (Loc, 3876 Left_Opnd => Make_Op_Ge (Loc, 3877 Left_Opnd => 3878 Make_Attribute_Reference (Loc, 3879 Prefix => 3880 New_Occurrence_Of (Target_Type, Loc), 3881 Attribute_Name => Name_First), 3882 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), 3883 3884 Right_Opnd => 3885 Make_Op_Lt (Loc, 3886 Left_Opnd => Duplicate_Subexpr (N), 3887 Right_Opnd => 3888 Convert_To (Source_Base_Type, 3889 Make_Attribute_Reference (Loc, 3890 Prefix => 3891 New_Occurrence_Of (Target_Type, Loc), 3892 Attribute_Name => Name_First)))), 3893 3894 Right_Opnd => 3895 Make_Op_Lt (Loc, 3896 Left_Opnd => 3897 Make_Attribute_Reference (Loc, 3898 Prefix => New_Occurrence_Of (Target_Type, Loc), 3899 Attribute_Name => Name_Last), 3900 Right_Opnd => Make_Integer_Literal (Loc, Uint_0))), 3901 3902 Right_Opnd => 3903 Make_Op_Gt (Loc, 3904 Left_Opnd => Duplicate_Subexpr (N), 3905 Right_Opnd => 3906 Convert_To (Source_Base_Type, 3907 Make_Attribute_Reference (Loc, 3908 Prefix => New_Occurrence_Of (Target_Type, Loc), 3909 Attribute_Name => Name_Last)))), 3910 3911 Reason => Reason), 3912 Suppress => All_Checks); 3913 3914 -- Only remaining possibility is that the source is signed and 3915 -- the target is unsigned 3916 3917 else 3918 pragma Assert (not Is_Unsigned_Type (Source_Base_Type) 3919 and then Is_Unsigned_Type (Target_Base_Type)); 3920 3921 -- If the source is signed and the target is unsigned, then 3922 -- we know that the target is not shorter than the source 3923 -- (otherwise the target base type would be in the source 3924 -- base type range). 3925 3926 -- In other words, the unsigned type is either the same size 3927 -- as the target, or it is larger. It cannot be smaller. 3928 3929 -- Clearly we have an error if the source value is negative 3930 -- since no unsigned type can have negative values. If the 3931 -- source type is non-negative, then the check can be done 3932 -- using the target type. 3933 3934 -- Tnn : constant Target_Base_Type (N) := Target_Type; 3935 3936 -- [constraint_error 3937 -- when N < 0 or else Tnn not in Target_Type]; 3938 3939 -- We turn off all checks for the conversion of N to the 3940 -- target base type, since we generate the explicit check 3941 -- to ensure that the value is non-negative 3942 3943 declare 3944 Tnn : constant Entity_Id := 3945 Make_Defining_Identifier (Loc, 3946 Chars => New_Internal_Name ('T')); 3947 3948 begin 3949 Insert_Actions (N, New_List ( 3950 Make_Object_Declaration (Loc, 3951 Defining_Identifier => Tnn, 3952 Object_Definition => 3953 New_Occurrence_Of (Target_Base_Type, Loc), 3954 Constant_Present => True, 3955 Expression => 3956 Make_Type_Conversion (Loc, 3957 Subtype_Mark => 3958 New_Occurrence_Of (Target_Base_Type, Loc), 3959 Expression => Duplicate_Subexpr (N))), 3960 3961 Make_Raise_Constraint_Error (Loc, 3962 Condition => 3963 Make_Or_Else (Loc, 3964 Left_Opnd => 3965 Make_Op_Lt (Loc, 3966 Left_Opnd => Duplicate_Subexpr (N), 3967 Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), 3968 3969 Right_Opnd => 3970 Make_Not_In (Loc, 3971 Left_Opnd => New_Occurrence_Of (Tnn, Loc), 3972 Right_Opnd => 3973 New_Occurrence_Of (Target_Type, Loc))), 3974 3975 Reason => Reason)), 3976 Suppress => All_Checks); 3977 3978 -- Set the Etype explicitly, because Insert_Actions may 3979 -- have placed the declaration in the freeze list for an 3980 -- enclosing construct, and thus it is not analyzed yet. 3981 3982 Set_Etype (Tnn, Target_Base_Type); 3983 Rewrite (N, New_Occurrence_Of (Tnn, Loc)); 3984 end; 3985 end if; 3986 end if; 3987 end Generate_Range_Check; 3988 3989 --------------------- 3990 -- Get_Discriminal -- 3991 --------------------- 3992 3993 function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is 3994 Loc : constant Source_Ptr := Sloc (E); 3995 D : Entity_Id; 3996 Sc : Entity_Id; 3997 3998 begin 3999 -- The entity E is the type of a private component of the protected 4000 -- type, or the type of a renaming of that component within a protected 4001 -- operation of that type. 4002 4003 Sc := Scope (E); 4004 4005 if Ekind (Sc) /= E_Protected_Type then 4006 Sc := Scope (Sc); 4007 4008 if Ekind (Sc) /= E_Protected_Type then 4009 return Bound; 4010 end if; 4011 end if; 4012 4013 D := First_Discriminant (Sc); 4014 4015 while Present (D) 4016 and then Chars (D) /= Chars (Bound) 4017 loop 4018 Next_Discriminant (D); 4019 end loop; 4020 4021 return New_Occurrence_Of (Discriminal (D), Loc); 4022 end Get_Discriminal; 4023 4024 ------------------ 4025 -- Guard_Access -- 4026 ------------------ 4027 4028 function Guard_Access 4029 (Cond : Node_Id; 4030 Loc : Source_Ptr; 4031 Ck_Node : Node_Id) 4032 return Node_Id 4033 is 4034 begin 4035 if Nkind (Cond) = N_Or_Else then 4036 Set_Paren_Count (Cond, 1); 4037 end if; 4038 4039 if Nkind (Ck_Node) = N_Allocator then 4040 return Cond; 4041 else 4042 return 4043 Make_And_Then (Loc, 4044 Left_Opnd => 4045 Make_Op_Ne (Loc, 4046 Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node), 4047 Right_Opnd => Make_Null (Loc)), 4048 Right_Opnd => Cond); 4049 end if; 4050 end Guard_Access; 4051 4052 ----------------------------- 4053 -- Index_Checks_Suppressed -- 4054 ----------------------------- 4055 4056 function Index_Checks_Suppressed (E : Entity_Id) return Boolean is 4057 begin 4058 if Present (E) and then Checks_May_Be_Suppressed (E) then 4059 return Is_Check_Suppressed (E, Index_Check); 4060 else 4061 return Scope_Suppress (Index_Check); 4062 end if; 4063 end Index_Checks_Suppressed; 4064 4065 ---------------- 4066 -- Initialize -- 4067 ---------------- 4068 4069 procedure Initialize is 4070 begin 4071 for J in Determine_Range_Cache_N'Range loop 4072 Determine_Range_Cache_N (J) := Empty; 4073 end loop; 4074 end Initialize; 4075 4076 ------------------------- 4077 -- Insert_Range_Checks -- 4078 ------------------------- 4079 4080 procedure Insert_Range_Checks 4081 (Checks : Check_Result; 4082 Node : Node_Id; 4083 Suppress_Typ : Entity_Id; 4084 Static_Sloc : Source_Ptr := No_Location; 4085 Flag_Node : Node_Id := Empty; 4086 Do_Before : Boolean := False) 4087 is 4088 Internal_Flag_Node : Node_Id := Flag_Node; 4089 Internal_Static_Sloc : Source_Ptr := Static_Sloc; 4090 4091 Check_Node : Node_Id; 4092 Checks_On : constant Boolean := 4093 (not Index_Checks_Suppressed (Suppress_Typ)) 4094 or else 4095 (not Range_Checks_Suppressed (Suppress_Typ)); 4096 4097 begin 4098 -- For now we just return if Checks_On is false, however this should 4099 -- be enhanced to check for an always True value in the condition 4100 -- and to generate a compilation warning??? 4101 4102 if not Expander_Active or else not Checks_On then 4103 return; 4104 end if; 4105 4106 if Static_Sloc = No_Location then 4107 Internal_Static_Sloc := Sloc (Node); 4108 end if; 4109 4110 if No (Flag_Node) then 4111 Internal_Flag_Node := Node; 4112 end if; 4113 4114 for J in 1 .. 2 loop 4115 exit when No (Checks (J)); 4116 4117 if Nkind (Checks (J)) = N_Raise_Constraint_Error 4118 and then Present (Condition (Checks (J))) 4119 then 4120 if not Has_Dynamic_Range_Check (Internal_Flag_Node) then 4121 Check_Node := Checks (J); 4122 Mark_Rewrite_Insertion (Check_Node); 4123 4124 if Do_Before then 4125 Insert_Before_And_Analyze (Node, Check_Node); 4126 else 4127 Insert_After_And_Analyze (Node, Check_Node); 4128 end if; 4129 4130 Set_Has_Dynamic_Range_Check (Internal_Flag_Node); 4131 end if; 4132 4133 else 4134 Check_Node := 4135 Make_Raise_Constraint_Error (Internal_Static_Sloc, 4136 Reason => CE_Range_Check_Failed); 4137 Mark_Rewrite_Insertion (Check_Node); 4138 4139 if Do_Before then 4140 Insert_Before_And_Analyze (Node, Check_Node); 4141 else 4142 Insert_After_And_Analyze (Node, Check_Node); 4143 end if; 4144 end if; 4145 end loop; 4146 end Insert_Range_Checks; 4147 4148 ------------------------ 4149 -- Insert_Valid_Check -- 4150 ------------------------ 4151 4152 procedure Insert_Valid_Check (Expr : Node_Id) is 4153 Loc : constant Source_Ptr := Sloc (Expr); 4154 Exp : Node_Id; 4155 4156 begin 4157 -- Do not insert if checks off, or if not checking validity 4158 4159 if Range_Checks_Suppressed (Etype (Expr)) 4160 or else (not Validity_Checks_On) 4161 then 4162 return; 4163 end if; 4164 4165 -- If we have a checked conversion, then validity check applies to 4166 -- the expression inside the conversion, not the result, since if 4167 -- the expression inside is valid, then so is the conversion result. 4168 4169 Exp := Expr; 4170 while Nkind (Exp) = N_Type_Conversion loop 4171 Exp := Expression (Exp); 4172 end loop; 4173 4174 -- Insert the validity check. Note that we do this with validity 4175 -- checks turned off, to avoid recursion, we do not want validity 4176 -- checks on the validity checking code itself! 4177 4178 Validity_Checks_On := False; 4179 Insert_Action 4180 (Expr, 4181 Make_Raise_Constraint_Error (Loc, 4182 Condition => 4183 Make_Op_Not (Loc, 4184 Right_Opnd => 4185 Make_Attribute_Reference (Loc, 4186 Prefix => 4187 Duplicate_Subexpr_No_Checks (Exp, Name_Req => True), 4188 Attribute_Name => Name_Valid)), 4189 Reason => CE_Invalid_Data), 4190 Suppress => All_Checks); 4191 Validity_Checks_On := True; 4192 end Insert_Valid_Check; 4193 4194 -------------------------- 4195 -- Install_Static_Check -- 4196 -------------------------- 4197 4198 procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is 4199 Stat : constant Boolean := Is_Static_Expression (R_Cno); 4200 Typ : constant Entity_Id := Etype (R_Cno); 4201 4202 begin 4203 Rewrite (R_Cno, 4204 Make_Raise_Constraint_Error (Loc, 4205 Reason => CE_Range_Check_Failed)); 4206 Set_Analyzed (R_Cno); 4207 Set_Etype (R_Cno, Typ); 4208 Set_Raises_Constraint_Error (R_Cno); 4209 Set_Is_Static_Expression (R_Cno, Stat); 4210 end Install_Static_Check; 4211 4212 --------------------- 4213 -- Kill_All_Checks -- 4214 --------------------- 4215 4216 procedure Kill_All_Checks is 4217 begin 4218 if Debug_Flag_CC then 4219 w ("Kill_All_Checks"); 4220 end if; 4221 4222 -- We reset the number of saved checks to zero, and also modify 4223 -- all stack entries for statement ranges to indicate that the 4224 -- number of checks at each level is now zero. 4225 4226 Num_Saved_Checks := 0; 4227 4228 for J in 1 .. Saved_Checks_TOS loop 4229 Saved_Checks_Stack (J) := 0; 4230 end loop; 4231 end Kill_All_Checks; 4232 4233 ----------------- 4234 -- Kill_Checks -- 4235 ----------------- 4236 4237 procedure Kill_Checks (V : Entity_Id) is 4238 begin 4239 if Debug_Flag_CC then 4240 w ("Kill_Checks for entity", Int (V)); 4241 end if; 4242 4243 for J in 1 .. Num_Saved_Checks loop 4244 if Saved_Checks (J).Entity = V then 4245 if Debug_Flag_CC then 4246 w (" Checks killed for saved check ", J); 4247 end if; 4248 4249 Saved_Checks (J).Killed := True; 4250 end if; 4251 end loop; 4252 end Kill_Checks; 4253 4254 ------------------------------ 4255 -- Length_Checks_Suppressed -- 4256 ------------------------------ 4257 4258 function Length_Checks_Suppressed (E : Entity_Id) return Boolean is 4259 begin 4260 if Present (E) and then Checks_May_Be_Suppressed (E) then 4261 return Is_Check_Suppressed (E, Length_Check); 4262 else 4263 return Scope_Suppress (Length_Check); 4264 end if; 4265 end Length_Checks_Suppressed; 4266 4267 -------------------------------- 4268 -- Overflow_Checks_Suppressed -- 4269 -------------------------------- 4270 4271 function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is 4272 begin 4273 if Present (E) and then Checks_May_Be_Suppressed (E) then 4274 return Is_Check_Suppressed (E, Overflow_Check); 4275 else 4276 return Scope_Suppress (Overflow_Check); 4277 end if; 4278 end Overflow_Checks_Suppressed; 4279 4280 ----------------- 4281 -- Range_Check -- 4282 ----------------- 4283 4284 function Range_Check 4285 (Ck_Node : Node_Id; 4286 Target_Typ : Entity_Id; 4287 Source_Typ : Entity_Id := Empty; 4288 Warn_Node : Node_Id := Empty) 4289 return Check_Result 4290 is 4291 begin 4292 return Selected_Range_Checks 4293 (Ck_Node, Target_Typ, Source_Typ, Warn_Node); 4294 end Range_Check; 4295 4296 ----------------------------- 4297 -- Range_Checks_Suppressed -- 4298 ----------------------------- 4299 4300 function Range_Checks_Suppressed (E : Entity_Id) return Boolean is 4301 begin 4302 if Present (E) then 4303 4304 -- Note: for now we always suppress range checks on Vax float types, 4305 -- since Gigi does not know how to generate these checks. 4306 4307 if Vax_Float (E) then 4308 return True; 4309 elsif Kill_Range_Checks (E) then 4310 return True; 4311 elsif Checks_May_Be_Suppressed (E) then 4312 return Is_Check_Suppressed (E, Range_Check); 4313 end if; 4314 end if; 4315 4316 return Scope_Suppress (Range_Check); 4317 end Range_Checks_Suppressed; 4318 4319 ------------------- 4320 -- Remove_Checks -- 4321 ------------------- 4322 4323 procedure Remove_Checks (Expr : Node_Id) is 4324 Discard : Traverse_Result; 4325 pragma Warnings (Off, Discard); 4326 4327 function Process (N : Node_Id) return Traverse_Result; 4328 -- Process a single node during the traversal 4329 4330 function Traverse is new Traverse_Func (Process); 4331 -- The traversal function itself 4332 4333 ------------- 4334 -- Process -- 4335 ------------- 4336 4337 function Process (N : Node_Id) return Traverse_Result is 4338 begin 4339 if Nkind (N) not in N_Subexpr then 4340 return Skip; 4341 end if; 4342 4343 Set_Do_Range_Check (N, False); 4344 4345 case Nkind (N) is 4346 when N_And_Then => 4347 Discard := Traverse (Left_Opnd (N)); 4348 return Skip; 4349 4350 when N_Attribute_Reference => 4351 Set_Do_Overflow_Check (N, False); 4352 4353 when N_Function_Call => 4354 Set_Do_Tag_Check (N, False); 4355 4356 when N_Op => 4357 Set_Do_Overflow_Check (N, False); 4358 4359 case Nkind (N) is 4360 when N_Op_Divide => 4361 Set_Do_Division_Check (N, False); 4362 4363 when N_Op_And => 4364 Set_Do_Length_Check (N, False); 4365 4366 when N_Op_Mod => 4367 Set_Do_Division_Check (N, False); 4368 4369 when N_Op_Or => 4370 Set_Do_Length_Check (N, False); 4371 4372 when N_Op_Rem => 4373 Set_Do_Division_Check (N, False); 4374 4375 when N_Op_Xor => 4376 Set_Do_Length_Check (N, False); 4377 4378 when others => 4379 null; 4380 end case; 4381 4382 when N_Or_Else => 4383 Discard := Traverse (Left_Opnd (N)); 4384 return Skip; 4385 4386 when N_Selected_Component => 4387 Set_Do_Discriminant_Check (N, False); 4388 4389 when N_Type_Conversion => 4390 Set_Do_Length_Check (N, False); 4391 Set_Do_Tag_Check (N, False); 4392 Set_Do_Overflow_Check (N, False); 4393 4394 when others => 4395 null; 4396 end case; 4397 4398 return OK; 4399 end Process; 4400 4401 -- Start of processing for Remove_Checks 4402 4403 begin 4404 Discard := Traverse (Expr); 4405 end Remove_Checks; 4406 4407 ---------------------------- 4408 -- Selected_Length_Checks -- 4409 ---------------------------- 4410 4411 function Selected_Length_Checks 4412 (Ck_Node : Node_Id; 4413 Target_Typ : Entity_Id; 4414 Source_Typ : Entity_Id; 4415 Warn_Node : Node_Id) 4416 return Check_Result 4417 is 4418 Loc : constant Source_Ptr := Sloc (Ck_Node); 4419 S_Typ : Entity_Id; 4420 T_Typ : Entity_Id; 4421 Expr_Actual : Node_Id; 4422 Exptyp : Entity_Id; 4423 Cond : Node_Id := Empty; 4424 Do_Access : Boolean := False; 4425 Wnode : Node_Id := Warn_Node; 4426 Ret_Result : Check_Result := (Empty, Empty); 4427 Num_Checks : Natural := 0; 4428 4429 procedure Add_Check (N : Node_Id); 4430 -- Adds the action given to Ret_Result if N is non-Empty 4431 4432 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id; 4433 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id; 4434 4435 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean; 4436 -- True for equal literals and for nodes that denote the same constant 4437 -- entity, even if its value is not a static constant. This includes the 4438 -- case of a discriminal reference within an init proc. Removes some 4439 -- obviously superfluous checks. 4440 4441 function Length_E_Cond 4442 (Exptyp : Entity_Id; 4443 Typ : Entity_Id; 4444 Indx : Nat) 4445 return Node_Id; 4446 -- Returns expression to compute: 4447 -- Typ'Length /= Exptyp'Length 4448 4449 function Length_N_Cond 4450 (Expr : Node_Id; 4451 Typ : Entity_Id; 4452 Indx : Nat) 4453 return Node_Id; 4454 -- Returns expression to compute: 4455 -- Typ'Length /= Expr'Length 4456 4457 --------------- 4458 -- Add_Check -- 4459 --------------- 4460 4461 procedure Add_Check (N : Node_Id) is 4462 begin 4463 if Present (N) then 4464 4465 -- For now, ignore attempt to place more than 2 checks ??? 4466 4467 if Num_Checks = 2 then 4468 return; 4469 end if; 4470 4471 pragma Assert (Num_Checks <= 1); 4472 Num_Checks := Num_Checks + 1; 4473 Ret_Result (Num_Checks) := N; 4474 end if; 4475 end Add_Check; 4476 4477 ------------------ 4478 -- Get_E_Length -- 4479 ------------------ 4480 4481 function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is 4482 Pt : constant Entity_Id := Scope (Scope (E)); 4483 N : Node_Id; 4484 E1 : Entity_Id := E; 4485 4486 begin 4487 if Ekind (Scope (E)) = E_Record_Type 4488 and then Has_Discriminants (Scope (E)) 4489 then 4490 N := Build_Discriminal_Subtype_Of_Component (E); 4491 4492 if Present (N) then 4493 Insert_Action (Ck_Node, N); 4494 E1 := Defining_Identifier (N); 4495 end if; 4496 end if; 4497 4498 if Ekind (E1) = E_String_Literal_Subtype then 4499 return 4500 Make_Integer_Literal (Loc, 4501 Intval => String_Literal_Length (E1)); 4502 4503 elsif Ekind (Pt) = E_Protected_Type 4504 and then Has_Discriminants (Pt) 4505 and then Has_Completion (Pt) 4506 and then not Inside_Init_Proc 4507 then 4508 4509 -- If the type whose length is needed is a private component 4510 -- constrained by a discriminant, we must expand the 'Length 4511 -- attribute into an explicit computation, using the discriminal 4512 -- of the current protected operation. This is because the actual 4513 -- type of the prival is constructed after the protected opera- 4514 -- tion has been fully expanded. 4515 4516 declare 4517 Indx_Type : Node_Id; 4518 Lo : Node_Id; 4519 Hi : Node_Id; 4520 Do_Expand : Boolean := False; 4521 4522 begin 4523 Indx_Type := First_Index (E); 4524 4525 for J in 1 .. Indx - 1 loop 4526 Next_Index (Indx_Type); 4527 end loop; 4528 4529 Get_Index_Bounds (Indx_Type, Lo, Hi); 4530 4531 if Nkind (Lo) = N_Identifier 4532 and then Ekind (Entity (Lo)) = E_In_Parameter 4533 then 4534 Lo := Get_Discriminal (E, Lo); 4535 Do_Expand := True; 4536 end if; 4537 4538 if Nkind (Hi) = N_Identifier 4539 and then Ekind (Entity (Hi)) = E_In_Parameter 4540 then 4541 Hi := Get_Discriminal (E, Hi); 4542 Do_Expand := True; 4543 end if; 4544 4545 if Do_Expand then 4546 if not Is_Entity_Name (Lo) then 4547 Lo := Duplicate_Subexpr_No_Checks (Lo); 4548 end if; 4549 4550 if not Is_Entity_Name (Hi) then 4551 Lo := Duplicate_Subexpr_No_Checks (Hi); 4552 end if; 4553 4554 N := 4555 Make_Op_Add (Loc, 4556 Left_Opnd => 4557 Make_Op_Subtract (Loc, 4558 Left_Opnd => Hi, 4559 Right_Opnd => Lo), 4560 4561 Right_Opnd => Make_Integer_Literal (Loc, 1)); 4562 return N; 4563 4564 else 4565 N := 4566 Make_Attribute_Reference (Loc, 4567 Attribute_Name => Name_Length, 4568 Prefix => 4569 New_Occurrence_Of (E1, Loc)); 4570 4571 if Indx > 1 then 4572 Set_Expressions (N, New_List ( 4573 Make_Integer_Literal (Loc, Indx))); 4574 end if; 4575 4576 return N; 4577 end if; 4578 end; 4579 4580 else 4581 N := 4582 Make_Attribute_Reference (Loc, 4583 Attribute_Name => Name_Length, 4584 Prefix => 4585 New_Occurrence_Of (E1, Loc)); 4586 4587 if Indx > 1 then 4588 Set_Expressions (N, New_List ( 4589 Make_Integer_Literal (Loc, Indx))); 4590 end if; 4591 4592 return N; 4593 4594 end if; 4595 end Get_E_Length; 4596 4597 ------------------ 4598 -- Get_N_Length -- 4599 ------------------ 4600 4601 function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is 4602 begin 4603 return 4604 Make_Attribute_Reference (Loc, 4605 Attribute_Name => Name_Length, 4606 Prefix => 4607 Duplicate_Subexpr_No_Checks (N, Name_Req => True), 4608 Expressions => New_List ( 4609 Make_Integer_Literal (Loc, Indx))); 4610 4611 end Get_N_Length; 4612 4613 ------------------- 4614 -- Length_E_Cond -- 4615 ------------------- 4616 4617 function Length_E_Cond 4618 (Exptyp : Entity_Id; 4619 Typ : Entity_Id; 4620 Indx : Nat) 4621 return Node_Id 4622 is 4623 begin 4624 return 4625 Make_Op_Ne (Loc, 4626 Left_Opnd => Get_E_Length (Typ, Indx), 4627 Right_Opnd => Get_E_Length (Exptyp, Indx)); 4628 4629 end Length_E_Cond; 4630 4631 ------------------- 4632 -- Length_N_Cond -- 4633 ------------------- 4634 4635 function Length_N_Cond 4636 (Expr : Node_Id; 4637 Typ : Entity_Id; 4638 Indx : Nat) 4639 return Node_Id 4640 is 4641 begin 4642 return 4643 Make_Op_Ne (Loc, 4644 Left_Opnd => Get_E_Length (Typ, Indx), 4645 Right_Opnd => Get_N_Length (Expr, Indx)); 4646 4647 end Length_N_Cond; 4648 4649 function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is 4650 begin 4651 return 4652 (Nkind (L) = N_Integer_Literal 4653 and then Nkind (R) = N_Integer_Literal 4654 and then Intval (L) = Intval (R)) 4655 4656 or else 4657 (Is_Entity_Name (L) 4658 and then Ekind (Entity (L)) = E_Constant 4659 and then ((Is_Entity_Name (R) 4660 and then Entity (L) = Entity (R)) 4661 or else 4662 (Nkind (R) = N_Type_Conversion 4663 and then Is_Entity_Name (Expression (R)) 4664 and then Entity (L) = Entity (Expression (R))))) 4665 4666 or else 4667 (Is_Entity_Name (R) 4668 and then Ekind (Entity (R)) = E_Constant 4669 and then Nkind (L) = N_Type_Conversion 4670 and then Is_Entity_Name (Expression (L)) 4671 and then Entity (R) = Entity (Expression (L))) 4672 4673 or else 4674 (Is_Entity_Name (L) 4675 and then Is_Entity_Name (R) 4676 and then Entity (L) = Entity (R) 4677 and then Ekind (Entity (L)) = E_In_Parameter 4678 and then Inside_Init_Proc); 4679 end Same_Bounds; 4680 4681 -- Start of processing for Selected_Length_Checks 4682 4683 begin 4684 if not Expander_Active then 4685 return Ret_Result; 4686 end if; 4687 4688 if Target_Typ = Any_Type 4689 or else Target_Typ = Any_Composite 4690 or else Raises_Constraint_Error (Ck_Node) 4691 then 4692 return Ret_Result; 4693 end if; 4694 4695 if No (Wnode) then 4696 Wnode := Ck_Node; 4697 end if; 4698 4699 T_Typ := Target_Typ; 4700 4701 if No (Source_Typ) then 4702 S_Typ := Etype (Ck_Node); 4703 else 4704 S_Typ := Source_Typ; 4705 end if; 4706 4707 if S_Typ = Any_Type or else S_Typ = Any_Composite then 4708 return Ret_Result; 4709 end if; 4710 4711 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then 4712 S_Typ := Designated_Type (S_Typ); 4713 T_Typ := Designated_Type (T_Typ); 4714 Do_Access := True; 4715 4716 -- A simple optimization 4717 4718 if Nkind (Ck_Node) = N_Null then 4719 return Ret_Result; 4720 end if; 4721 end if; 4722 4723 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then 4724 if Is_Constrained (T_Typ) then 4725 4726 -- The checking code to be generated will freeze the 4727 -- corresponding array type. However, we must freeze the 4728 -- type now, so that the freeze node does not appear within 4729 -- the generated condional expression, but ahead of it. 4730 4731 Freeze_Before (Ck_Node, T_Typ); 4732 4733 Expr_Actual := Get_Referenced_Object (Ck_Node); 4734 Exptyp := Get_Actual_Subtype (Expr_Actual); 4735 4736 if Is_Access_Type (Exptyp) then 4737 Exptyp := Designated_Type (Exptyp); 4738 end if; 4739 4740 -- String_Literal case. This needs to be handled specially be- 4741 -- cause no index types are available for string literals. The 4742 -- condition is simply: 4743 4744 -- T_Typ'Length = string-literal-length 4745 4746 if Nkind (Expr_Actual) = N_String_Literal 4747 and then Ekind (Etype (Expr_Actual)) = E_String_Literal_Subtype 4748 then 4749 Cond := 4750 Make_Op_Ne (Loc, 4751 Left_Opnd => Get_E_Length (T_Typ, 1), 4752 Right_Opnd => 4753 Make_Integer_Literal (Loc, 4754 Intval => 4755 String_Literal_Length (Etype (Expr_Actual)))); 4756 4757 -- General array case. Here we have a usable actual subtype for 4758 -- the expression, and the condition is built from the two types 4759 -- (Do_Length): 4760 4761 -- T_Typ'Length /= Exptyp'Length or else 4762 -- T_Typ'Length (2) /= Exptyp'Length (2) or else 4763 -- T_Typ'Length (3) /= Exptyp'Length (3) or else 4764 -- ... 4765 4766 elsif Is_Constrained (Exptyp) then 4767 declare 4768 Ndims : constant Nat := Number_Dimensions (T_Typ); 4769 4770 L_Index : Node_Id; 4771 R_Index : Node_Id; 4772 L_Low : Node_Id; 4773 L_High : Node_Id; 4774 R_Low : Node_Id; 4775 R_High : Node_Id; 4776 L_Length : Uint; 4777 R_Length : Uint; 4778 Ref_Node : Node_Id; 4779 4780 begin 4781 4782 -- At the library level, we need to ensure that the 4783 -- type of the object is elaborated before the check 4784 -- itself is emitted. This is only done if the object 4785 -- is in the current compilation unit, otherwise the 4786 -- type is frozen and elaborated in its unit. 4787 4788 if Is_Itype (Exptyp) 4789 and then 4790 Ekind (Cunit_Entity (Current_Sem_Unit)) = E_Package 4791 and then 4792 not In_Package_Body (Cunit_Entity (Current_Sem_Unit)) 4793 and then In_Open_Scopes (Scope (Exptyp)) 4794 then 4795 Ref_Node := Make_Itype_Reference (Sloc (Ck_Node)); 4796 Set_Itype (Ref_Node, Exptyp); 4797 Insert_Action (Ck_Node, Ref_Node); 4798 end if; 4799 4800 L_Index := First_Index (T_Typ); 4801 R_Index := First_Index (Exptyp); 4802 4803 for Indx in 1 .. Ndims loop 4804 if not (Nkind (L_Index) = N_Raise_Constraint_Error 4805 or else 4806 Nkind (R_Index) = N_Raise_Constraint_Error) 4807 then 4808 Get_Index_Bounds (L_Index, L_Low, L_High); 4809 Get_Index_Bounds (R_Index, R_Low, R_High); 4810 4811 -- Deal with compile time length check. Note that we 4812 -- skip this in the access case, because the access 4813 -- value may be null, so we cannot know statically. 4814 4815 if not Do_Access 4816 and then Compile_Time_Known_Value (L_Low) 4817 and then Compile_Time_Known_Value (L_High) 4818 and then Compile_Time_Known_Value (R_Low) 4819 and then Compile_Time_Known_Value (R_High) 4820 then 4821 if Expr_Value (L_High) >= Expr_Value (L_Low) then 4822 L_Length := Expr_Value (L_High) - 4823 Expr_Value (L_Low) + 1; 4824 else 4825 L_Length := UI_From_Int (0); 4826 end if; 4827 4828 if Expr_Value (R_High) >= Expr_Value (R_Low) then 4829 R_Length := Expr_Value (R_High) - 4830 Expr_Value (R_Low) + 1; 4831 else 4832 R_Length := UI_From_Int (0); 4833 end if; 4834 4835 if L_Length > R_Length then 4836 Add_Check 4837 (Compile_Time_Constraint_Error 4838 (Wnode, "too few elements for}?", T_Typ)); 4839 4840 elsif L_Length < R_Length then 4841 Add_Check 4842 (Compile_Time_Constraint_Error 4843 (Wnode, "too many elements for}?", T_Typ)); 4844 end if; 4845 4846 -- The comparison for an individual index subtype 4847 -- is omitted if the corresponding index subtypes 4848 -- statically match, since the result is known to 4849 -- be true. Note that this test is worth while even 4850 -- though we do static evaluation, because non-static 4851 -- subtypes can statically match. 4852 4853 elsif not 4854 Subtypes_Statically_Match 4855 (Etype (L_Index), Etype (R_Index)) 4856 4857 and then not 4858 (Same_Bounds (L_Low, R_Low) 4859 and then Same_Bounds (L_High, R_High)) 4860 then 4861 Evolve_Or_Else 4862 (Cond, Length_E_Cond (Exptyp, T_Typ, Indx)); 4863 end if; 4864 4865 Next (L_Index); 4866 Next (R_Index); 4867 end if; 4868 end loop; 4869 end; 4870 4871 -- Handle cases where we do not get a usable actual subtype that 4872 -- is constrained. This happens for example in the function call 4873 -- and explicit dereference cases. In these cases, we have to get 4874 -- the length or range from the expression itself, making sure we 4875 -- do not evaluate it more than once. 4876 4877 -- Here Ck_Node is the original expression, or more properly the 4878 -- result of applying Duplicate_Expr to the original tree, 4879 -- forcing the result to be a name. 4880 4881 else 4882 declare 4883 Ndims : constant Nat := Number_Dimensions (T_Typ); 4884 4885 begin 4886 -- Build the condition for the explicit dereference case 4887 4888 for Indx in 1 .. Ndims loop 4889 Evolve_Or_Else 4890 (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx)); 4891 end loop; 4892 end; 4893 end if; 4894 end if; 4895 end if; 4896 4897 -- Construct the test and insert into the tree 4898 4899 if Present (Cond) then 4900 if Do_Access then 4901 Cond := Guard_Access (Cond, Loc, Ck_Node); 4902 end if; 4903 4904 Add_Check 4905 (Make_Raise_Constraint_Error (Loc, 4906 Condition => Cond, 4907 Reason => CE_Length_Check_Failed)); 4908 end if; 4909 4910 return Ret_Result; 4911 end Selected_Length_Checks; 4912 4913 --------------------------- 4914 -- Selected_Range_Checks -- 4915 --------------------------- 4916 4917 function Selected_Range_Checks 4918 (Ck_Node : Node_Id; 4919 Target_Typ : Entity_Id; 4920 Source_Typ : Entity_Id; 4921 Warn_Node : Node_Id) 4922 return Check_Result 4923 is 4924 Loc : constant Source_Ptr := Sloc (Ck_Node); 4925 S_Typ : Entity_Id; 4926 T_Typ : Entity_Id; 4927 Expr_Actual : Node_Id; 4928 Exptyp : Entity_Id; 4929 Cond : Node_Id := Empty; 4930 Do_Access : Boolean := False; 4931 Wnode : Node_Id := Warn_Node; 4932 Ret_Result : Check_Result := (Empty, Empty); 4933 Num_Checks : Integer := 0; 4934 4935 procedure Add_Check (N : Node_Id); 4936 -- Adds the action given to Ret_Result if N is non-Empty 4937 4938 function Discrete_Range_Cond 4939 (Expr : Node_Id; 4940 Typ : Entity_Id) 4941 return Node_Id; 4942 -- Returns expression to compute: 4943 -- Low_Bound (Expr) < Typ'First 4944 -- or else 4945 -- High_Bound (Expr) > Typ'Last 4946 4947 function Discrete_Expr_Cond 4948 (Expr : Node_Id; 4949 Typ : Entity_Id) 4950 return Node_Id; 4951 -- Returns expression to compute: 4952 -- Expr < Typ'First 4953 -- or else 4954 -- Expr > Typ'Last 4955 4956 function Get_E_First_Or_Last 4957 (E : Entity_Id; 4958 Indx : Nat; 4959 Nam : Name_Id) 4960 return Node_Id; 4961 -- Returns expression to compute: 4962 -- E'First or E'Last 4963 4964 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id; 4965 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id; 4966 -- Returns expression to compute: 4967 -- N'First or N'Last using Duplicate_Subexpr_No_Checks 4968 4969 function Range_E_Cond 4970 (Exptyp : Entity_Id; 4971 Typ : Entity_Id; 4972 Indx : Nat) 4973 return Node_Id; 4974 -- Returns expression to compute: 4975 -- Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last 4976 4977 function Range_Equal_E_Cond 4978 (Exptyp : Entity_Id; 4979 Typ : Entity_Id; 4980 Indx : Nat) 4981 return Node_Id; 4982 -- Returns expression to compute: 4983 -- Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last 4984 4985 function Range_N_Cond 4986 (Expr : Node_Id; 4987 Typ : Entity_Id; 4988 Indx : Nat) 4989 return Node_Id; 4990 -- Return expression to compute: 4991 -- Expr'First < Typ'First or else Expr'Last > Typ'Last 4992 4993 --------------- 4994 -- Add_Check -- 4995 --------------- 4996 4997 procedure Add_Check (N : Node_Id) is 4998 begin 4999 if Present (N) then 5000 5001 -- For now, ignore attempt to place more than 2 checks ??? 5002 5003 if Num_Checks = 2 then 5004 return; 5005 end if; 5006 5007 pragma Assert (Num_Checks <= 1); 5008 Num_Checks := Num_Checks + 1; 5009 Ret_Result (Num_Checks) := N; 5010 end if; 5011 end Add_Check; 5012 5013 ------------------------- 5014 -- Discrete_Expr_Cond -- 5015 ------------------------- 5016 5017 function Discrete_Expr_Cond 5018 (Expr : Node_Id; 5019 Typ : Entity_Id) 5020 return Node_Id 5021 is 5022 begin 5023 return 5024 Make_Or_Else (Loc, 5025 Left_Opnd => 5026 Make_Op_Lt (Loc, 5027 Left_Opnd => 5028 Convert_To (Base_Type (Typ), 5029 Duplicate_Subexpr_No_Checks (Expr)), 5030 Right_Opnd => 5031 Convert_To (Base_Type (Typ), 5032 Get_E_First_Or_Last (Typ, 0, Name_First))), 5033 5034 Right_Opnd => 5035 Make_Op_Gt (Loc, 5036 Left_Opnd => 5037 Convert_To (Base_Type (Typ), 5038 Duplicate_Subexpr_No_Checks (Expr)), 5039 Right_Opnd => 5040 Convert_To 5041 (Base_Type (Typ), 5042 Get_E_First_Or_Last (Typ, 0, Name_Last)))); 5043 end Discrete_Expr_Cond; 5044 5045 ------------------------- 5046 -- Discrete_Range_Cond -- 5047 ------------------------- 5048 5049 function Discrete_Range_Cond 5050 (Expr : Node_Id; 5051 Typ : Entity_Id) 5052 return Node_Id 5053 is 5054 LB : Node_Id := Low_Bound (Expr); 5055 HB : Node_Id := High_Bound (Expr); 5056 5057 Left_Opnd : Node_Id; 5058 Right_Opnd : Node_Id; 5059 5060 begin 5061 if Nkind (LB) = N_Identifier 5062 and then Ekind (Entity (LB)) = E_Discriminant then 5063 LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc); 5064 end if; 5065 5066 if Nkind (HB) = N_Identifier 5067 and then Ekind (Entity (HB)) = E_Discriminant then 5068 HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc); 5069 end if; 5070 5071 Left_Opnd := 5072 Make_Op_Lt (Loc, 5073 Left_Opnd => 5074 Convert_To 5075 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)), 5076 5077 Right_Opnd => 5078 Convert_To 5079 (Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First))); 5080 5081 if Base_Type (Typ) = Typ then 5082 return Left_Opnd; 5083 5084 elsif Compile_Time_Known_Value (High_Bound (Scalar_Range (Typ))) 5085 and then 5086 Compile_Time_Known_Value (High_Bound (Scalar_Range 5087 (Base_Type (Typ)))) 5088 then 5089 if Is_Floating_Point_Type (Typ) then 5090 if Expr_Value_R (High_Bound (Scalar_Range (Typ))) = 5091 Expr_Value_R (High_Bound (Scalar_Range (Base_Type (Typ)))) 5092 then 5093 return Left_Opnd; 5094 end if; 5095 5096 else 5097 if Expr_Value (High_Bound (Scalar_Range (Typ))) = 5098 Expr_Value (High_Bound (Scalar_Range (Base_Type (Typ)))) 5099 then 5100 return Left_Opnd; 5101 end if; 5102 end if; 5103 end if; 5104 5105 Right_Opnd := 5106 Make_Op_Gt (Loc, 5107 Left_Opnd => 5108 Convert_To 5109 (Base_Type (Typ), Duplicate_Subexpr_No_Checks (HB)), 5110 5111 Right_Opnd => 5112 Convert_To 5113 (Base_Type (Typ), 5114 Get_E_First_Or_Last (Typ, 0, Name_Last))); 5115 5116 return Make_Or_Else (Loc, Left_Opnd, Right_Opnd); 5117 end Discrete_Range_Cond; 5118 5119 ------------------------- 5120 -- Get_E_First_Or_Last -- 5121 ------------------------- 5122 5123 function Get_E_First_Or_Last 5124 (E : Entity_Id; 5125 Indx : Nat; 5126 Nam : Name_Id) 5127 return Node_Id 5128 is 5129 N : Node_Id; 5130 LB : Node_Id; 5131 HB : Node_Id; 5132 Bound : Node_Id; 5133 5134 begin 5135 if Is_Array_Type (E) then 5136 N := First_Index (E); 5137 5138 for J in 2 .. Indx loop 5139 Next_Index (N); 5140 end loop; 5141 5142 else 5143 N := Scalar_Range (E); 5144 end if; 5145 5146 if Nkind (N) = N_Subtype_Indication then 5147 LB := Low_Bound (Range_Expression (Constraint (N))); 5148 HB := High_Bound (Range_Expression (Constraint (N))); 5149 5150 elsif Is_Entity_Name (N) then 5151 LB := Type_Low_Bound (Etype (N)); 5152 HB := Type_High_Bound (Etype (N)); 5153 5154 else 5155 LB := Low_Bound (N); 5156 HB := High_Bound (N); 5157 end if; 5158 5159 if Nam = Name_First then 5160 Bound := LB; 5161 else 5162 Bound := HB; 5163 end if; 5164 5165 if Nkind (Bound) = N_Identifier 5166 and then Ekind (Entity (Bound)) = E_Discriminant 5167 then 5168 -- If this is a task discriminant, and we are the body, we must 5169 -- retrieve the corresponding body discriminal. This is another 5170 -- consequence of the early creation of discriminals, and the 5171 -- need to generate constraint checks before their declarations 5172 -- are made visible. 5173 5174 if Is_Concurrent_Record_Type (Scope (Entity (Bound))) then 5175 declare 5176 Tsk : constant Entity_Id := 5177 Corresponding_Concurrent_Type 5178 (Scope (Entity (Bound))); 5179 Disc : Entity_Id; 5180 5181 begin 5182 if In_Open_Scopes (Tsk) 5183 and then Has_Completion (Tsk) 5184 then 5185 -- Find discriminant of original task, and use its 5186 -- current discriminal, which is the renaming within 5187 -- the task body. 5188 5189 Disc := First_Discriminant (Tsk); 5190 while Present (Disc) loop 5191 if Chars (Disc) = Chars (Entity (Bound)) then 5192 Set_Scope (Discriminal (Disc), Tsk); 5193 return New_Occurrence_Of (Discriminal (Disc), Loc); 5194 end if; 5195 5196 Next_Discriminant (Disc); 5197 end loop; 5198 5199 -- That loop should always succeed in finding a matching 5200 -- entry and returning. Fatal error if not. 5201 5202 raise Program_Error; 5203 5204 else 5205 return 5206 New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); 5207 end if; 5208 end; 5209 else 5210 return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc); 5211 end if; 5212 5213 elsif Nkind (Bound) = N_Identifier 5214 and then Ekind (Entity (Bound)) = E_In_Parameter 5215 and then not Inside_Init_Proc 5216 then 5217 return Get_Discriminal (E, Bound); 5218 5219 elsif Nkind (Bound) = N_Integer_Literal then 5220 return Make_Integer_Literal (Loc, Intval (Bound)); 5221 5222 else 5223 return Duplicate_Subexpr_No_Checks (Bound); 5224 end if; 5225 end Get_E_First_Or_Last; 5226 5227 ----------------- 5228 -- Get_N_First -- 5229 ----------------- 5230 5231 function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is 5232 begin 5233 return 5234 Make_Attribute_Reference (Loc, 5235 Attribute_Name => Name_First, 5236 Prefix => 5237 Duplicate_Subexpr_No_Checks (N, Name_Req => True), 5238 Expressions => New_List ( 5239 Make_Integer_Literal (Loc, Indx))); 5240 5241 end Get_N_First; 5242 5243 ---------------- 5244 -- Get_N_Last -- 5245 ---------------- 5246 5247 function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is 5248 begin 5249 return 5250 Make_Attribute_Reference (Loc, 5251 Attribute_Name => Name_Last, 5252 Prefix => 5253 Duplicate_Subexpr_No_Checks (N, Name_Req => True), 5254 Expressions => New_List ( 5255 Make_Integer_Literal (Loc, Indx))); 5256 5257 end Get_N_Last; 5258 5259 ------------------ 5260 -- Range_E_Cond -- 5261 ------------------ 5262 5263 function Range_E_Cond 5264 (Exptyp : Entity_Id; 5265 Typ : Entity_Id; 5266 Indx : Nat) 5267 return Node_Id 5268 is 5269 begin 5270 return 5271 Make_Or_Else (Loc, 5272 Left_Opnd => 5273 Make_Op_Lt (Loc, 5274 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First), 5275 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)), 5276 5277 Right_Opnd => 5278 Make_Op_Gt (Loc, 5279 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last), 5280 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); 5281 5282 end Range_E_Cond; 5283 5284 ------------------------ 5285 -- Range_Equal_E_Cond -- 5286 ------------------------ 5287 5288 function Range_Equal_E_Cond 5289 (Exptyp : Entity_Id; 5290 Typ : Entity_Id; 5291 Indx : Nat) 5292 return Node_Id 5293 is 5294 begin 5295 return 5296 Make_Or_Else (Loc, 5297 Left_Opnd => 5298 Make_Op_Ne (Loc, 5299 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First), 5300 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)), 5301 Right_Opnd => 5302 Make_Op_Ne (Loc, 5303 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last), 5304 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); 5305 end Range_Equal_E_Cond; 5306 5307 ------------------ 5308 -- Range_N_Cond -- 5309 ------------------ 5310 5311 function Range_N_Cond 5312 (Expr : Node_Id; 5313 Typ : Entity_Id; 5314 Indx : Nat) 5315 return Node_Id 5316 is 5317 begin 5318 return 5319 Make_Or_Else (Loc, 5320 Left_Opnd => 5321 Make_Op_Lt (Loc, 5322 Left_Opnd => Get_N_First (Expr, Indx), 5323 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)), 5324 5325 Right_Opnd => 5326 Make_Op_Gt (Loc, 5327 Left_Opnd => Get_N_Last (Expr, Indx), 5328 Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); 5329 end Range_N_Cond; 5330 5331 -- Start of processing for Selected_Range_Checks 5332 5333 begin 5334 if not Expander_Active then 5335 return Ret_Result; 5336 end if; 5337 5338 if Target_Typ = Any_Type 5339 or else Target_Typ = Any_Composite 5340 or else Raises_Constraint_Error (Ck_Node) 5341 then 5342 return Ret_Result; 5343 end if; 5344 5345 if No (Wnode) then 5346 Wnode := Ck_Node; 5347 end if; 5348 5349 T_Typ := Target_Typ; 5350 5351 if No (Source_Typ) then 5352 S_Typ := Etype (Ck_Node); 5353 else 5354 S_Typ := Source_Typ; 5355 end if; 5356 5357 if S_Typ = Any_Type or else S_Typ = Any_Composite then 5358 return Ret_Result; 5359 end if; 5360 5361 -- The order of evaluating T_Typ before S_Typ seems to be critical 5362 -- because S_Typ can be derived from Etype (Ck_Node), if it's not passed 5363 -- in, and since Node can be an N_Range node, it might be invalid. 5364 -- Should there be an assert check somewhere for taking the Etype of 5365 -- an N_Range node ??? 5366 5367 if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then 5368 S_Typ := Designated_Type (S_Typ); 5369 T_Typ := Designated_Type (T_Typ); 5370 Do_Access := True; 5371 5372 -- A simple optimization 5373 5374 if Nkind (Ck_Node) = N_Null then 5375 return Ret_Result; 5376 end if; 5377 end if; 5378 5379 -- For an N_Range Node, check for a null range and then if not 5380 -- null generate a range check action. 5381 5382 if Nkind (Ck_Node) = N_Range then 5383 5384 -- There's no point in checking a range against itself 5385 5386 if Ck_Node = Scalar_Range (T_Typ) then 5387 return Ret_Result; 5388 end if; 5389 5390 declare 5391 T_LB : constant Node_Id := Type_Low_Bound (T_Typ); 5392 T_HB : constant Node_Id := Type_High_Bound (T_Typ); 5393 LB : constant Node_Id := Low_Bound (Ck_Node); 5394 HB : constant Node_Id := High_Bound (Ck_Node); 5395 Null_Range : Boolean; 5396 5397 Out_Of_Range_L : Boolean; 5398 Out_Of_Range_H : Boolean; 5399 5400 begin 5401 -- Check for case where everything is static and we can 5402 -- do the check at compile time. This is skipped if we 5403 -- have an access type, since the access value may be null. 5404 5405 -- ??? This code can be improved since you only need to know 5406 -- that the two respective bounds (LB & T_LB or HB & T_HB) 5407 -- are known at compile time to emit pertinent messages. 5408 5409 if Compile_Time_Known_Value (LB) 5410 and then Compile_Time_Known_Value (HB) 5411 and then Compile_Time_Known_Value (T_LB) 5412 and then Compile_Time_Known_Value (T_HB) 5413 and then not Do_Access 5414 then 5415 -- Floating-point case 5416 5417 if Is_Floating_Point_Type (S_Typ) then 5418 Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB); 5419 Out_Of_Range_L := 5420 (Expr_Value_R (LB) < Expr_Value_R (T_LB)) 5421 or else 5422 (Expr_Value_R (LB) > Expr_Value_R (T_HB)); 5423 5424 Out_Of_Range_H := 5425 (Expr_Value_R (HB) > Expr_Value_R (T_HB)) 5426 or else 5427 (Expr_Value_R (HB) < Expr_Value_R (T_LB)); 5428 5429 -- Fixed or discrete type case 5430 5431 else 5432 Null_Range := Expr_Value (HB) < Expr_Value (LB); 5433 Out_Of_Range_L := 5434 (Expr_Value (LB) < Expr_Value (T_LB)) 5435 or else 5436 (Expr_Value (LB) > Expr_Value (T_HB)); 5437 5438 Out_Of_Range_H := 5439 (Expr_Value (HB) > Expr_Value (T_HB)) 5440 or else 5441 (Expr_Value (HB) < Expr_Value (T_LB)); 5442 end if; 5443 5444 if not Null_Range then 5445 if Out_Of_Range_L then 5446 if No (Warn_Node) then 5447 Add_Check 5448 (Compile_Time_Constraint_Error 5449 (Low_Bound (Ck_Node), 5450 "static value out of range of}?", T_Typ)); 5451 5452 else 5453 Add_Check 5454 (Compile_Time_Constraint_Error 5455 (Wnode, 5456 "static range out of bounds of}?", T_Typ)); 5457 end if; 5458 end if; 5459 5460 if Out_Of_Range_H then 5461 if No (Warn_Node) then 5462 Add_Check 5463 (Compile_Time_Constraint_Error 5464 (High_Bound (Ck_Node), 5465 "static value out of range of}?", T_Typ)); 5466 5467 else 5468 Add_Check 5469 (Compile_Time_Constraint_Error 5470 (Wnode, 5471 "static range out of bounds of}?", T_Typ)); 5472 end if; 5473 end if; 5474 5475 end if; 5476 5477 else 5478 declare 5479 LB : Node_Id := Low_Bound (Ck_Node); 5480 HB : Node_Id := High_Bound (Ck_Node); 5481 5482 begin 5483 5484 -- If either bound is a discriminant and we are within 5485 -- the record declaration, it is a use of the discriminant 5486 -- in a constraint of a component, and nothing can be 5487 -- checked here. The check will be emitted within the 5488 -- init proc. Before then, the discriminal has no real 5489 -- meaning. 5490 5491 if Nkind (LB) = N_Identifier 5492 and then Ekind (Entity (LB)) = E_Discriminant 5493 then 5494 if Current_Scope = Scope (Entity (LB)) then 5495 return Ret_Result; 5496 else 5497 LB := 5498 New_Occurrence_Of (Discriminal (Entity (LB)), Loc); 5499 end if; 5500 end if; 5501 5502 if Nkind (HB) = N_Identifier 5503 and then Ekind (Entity (HB)) = E_Discriminant 5504 then 5505 if Current_Scope = Scope (Entity (HB)) then 5506 return Ret_Result; 5507 else 5508 HB := 5509 New_Occurrence_Of (Discriminal (Entity (HB)), Loc); 5510 end if; 5511 end if; 5512 5513 Cond := Discrete_Range_Cond (Ck_Node, T_Typ); 5514 Set_Paren_Count (Cond, 1); 5515 5516 Cond := 5517 Make_And_Then (Loc, 5518 Left_Opnd => 5519 Make_Op_Ge (Loc, 5520 Left_Opnd => Duplicate_Subexpr_No_Checks (HB), 5521 Right_Opnd => Duplicate_Subexpr_No_Checks (LB)), 5522 Right_Opnd => Cond); 5523 end; 5524 5525 end if; 5526 end; 5527 5528 elsif Is_Scalar_Type (S_Typ) then 5529 5530 -- This somewhat duplicates what Apply_Scalar_Range_Check does, 5531 -- except the above simply sets a flag in the node and lets 5532 -- gigi generate the check base on the Etype of the expression. 5533 -- Sometimes, however we want to do a dynamic check against an 5534 -- arbitrary target type, so we do that here. 5535 5536 if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then 5537 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); 5538 5539 -- For literals, we can tell if the constraint error will be 5540 -- raised at compile time, so we never need a dynamic check, but 5541 -- if the exception will be raised, then post the usual warning, 5542 -- and replace the literal with a raise constraint error 5543 -- expression. As usual, skip this for access types 5544 5545 elsif Compile_Time_Known_Value (Ck_Node) 5546 and then not Do_Access 5547 then 5548 declare 5549 LB : constant Node_Id := Type_Low_Bound (T_Typ); 5550 UB : constant Node_Id := Type_High_Bound (T_Typ); 5551 5552 Out_Of_Range : Boolean; 5553 Static_Bounds : constant Boolean := 5554 Compile_Time_Known_Value (LB) 5555 and Compile_Time_Known_Value (UB); 5556 5557 begin 5558 -- Following range tests should use Sem_Eval routine ??? 5559 5560 if Static_Bounds then 5561 if Is_Floating_Point_Type (S_Typ) then 5562 Out_Of_Range := 5563 (Expr_Value_R (Ck_Node) < Expr_Value_R (LB)) 5564 or else 5565 (Expr_Value_R (Ck_Node) > Expr_Value_R (UB)); 5566 5567 else -- fixed or discrete type 5568 Out_Of_Range := 5569 Expr_Value (Ck_Node) < Expr_Value (LB) 5570 or else 5571 Expr_Value (Ck_Node) > Expr_Value (UB); 5572 end if; 5573 5574 -- Bounds of the type are static and the literal is 5575 -- out of range so make a warning message. 5576 5577 if Out_Of_Range then 5578 if No (Warn_Node) then 5579 Add_Check 5580 (Compile_Time_Constraint_Error 5581 (Ck_Node, 5582 "static value out of range of}?", T_Typ)); 5583 5584 else 5585 Add_Check 5586 (Compile_Time_Constraint_Error 5587 (Wnode, 5588 "static value out of range of}?", T_Typ)); 5589 end if; 5590 end if; 5591 5592 else 5593 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); 5594 end if; 5595 end; 5596 5597 -- Here for the case of a non-static expression, we need a runtime 5598 -- check unless the source type range is guaranteed to be in the 5599 -- range of the target type. 5600 5601 else 5602 if not In_Subrange_Of (S_Typ, T_Typ) then 5603 Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); 5604 end if; 5605 end if; 5606 end if; 5607 5608 if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then 5609 if Is_Constrained (T_Typ) then 5610 5611 Expr_Actual := Get_Referenced_Object (Ck_Node); 5612 Exptyp := Get_Actual_Subtype (Expr_Actual); 5613 5614 if Is_Access_Type (Exptyp) then 5615 Exptyp := Designated_Type (Exptyp); 5616 end if; 5617 5618 -- String_Literal case. This needs to be handled specially be- 5619 -- cause no index types are available for string literals. The 5620 -- condition is simply: 5621 5622 -- T_Typ'Length = string-literal-length 5623 5624 if Nkind (Expr_Actual) = N_String_Literal then 5625 null; 5626 5627 -- General array case. Here we have a usable actual subtype for 5628 -- the expression, and the condition is built from the two types 5629 5630 -- T_Typ'First < Exptyp'First or else 5631 -- T_Typ'Last > Exptyp'Last or else 5632 -- T_Typ'First(1) < Exptyp'First(1) or else 5633 -- T_Typ'Last(1) > Exptyp'Last(1) or else 5634 -- ... 5635 5636 elsif Is_Constrained (Exptyp) then 5637 declare 5638 Ndims : constant Nat := Number_Dimensions (T_Typ); 5639 5640 L_Index : Node_Id; 5641 R_Index : Node_Id; 5642 L_Low : Node_Id; 5643 L_High : Node_Id; 5644 R_Low : Node_Id; 5645 R_High : Node_Id; 5646 5647 begin 5648 L_Index := First_Index (T_Typ); 5649 R_Index := First_Index (Exptyp); 5650 5651 for Indx in 1 .. Ndims loop 5652 if not (Nkind (L_Index) = N_Raise_Constraint_Error 5653 or else 5654 Nkind (R_Index) = N_Raise_Constraint_Error) 5655 then 5656 Get_Index_Bounds (L_Index, L_Low, L_High); 5657 Get_Index_Bounds (R_Index, R_Low, R_High); 5658 5659 -- Deal with compile time length check. Note that we 5660 -- skip this in the access case, because the access 5661 -- value may be null, so we cannot know statically. 5662 5663 if not 5664 Subtypes_Statically_Match 5665 (Etype (L_Index), Etype (R_Index)) 5666 then 5667 -- If the target type is constrained then we 5668 -- have to check for exact equality of bounds 5669 -- (required for qualified expressions). 5670 5671 if Is_Constrained (T_Typ) then 5672 Evolve_Or_Else 5673 (Cond, 5674 Range_Equal_E_Cond (Exptyp, T_Typ, Indx)); 5675 5676 else 5677 Evolve_Or_Else 5678 (Cond, Range_E_Cond (Exptyp, T_Typ, Indx)); 5679 end if; 5680 end if; 5681 5682 Next (L_Index); 5683 Next (R_Index); 5684 5685 end if; 5686 end loop; 5687 end; 5688 5689 -- Handle cases where we do not get a usable actual subtype that 5690 -- is constrained. This happens for example in the function call 5691 -- and explicit dereference cases. In these cases, we have to get 5692 -- the length or range from the expression itself, making sure we 5693 -- do not evaluate it more than once. 5694 5695 -- Here Ck_Node is the original expression, or more properly the 5696 -- result of applying Duplicate_Expr to the original tree, 5697 -- forcing the result to be a name. 5698 5699 else 5700 declare 5701 Ndims : constant Nat := Number_Dimensions (T_Typ); 5702 5703 begin 5704 -- Build the condition for the explicit dereference case 5705 5706 for Indx in 1 .. Ndims loop 5707 Evolve_Or_Else 5708 (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx)); 5709 end loop; 5710 end; 5711 5712 end if; 5713 5714 else 5715 -- Generate an Action to check that the bounds of the 5716 -- source value are within the constraints imposed by the 5717 -- target type for a conversion to an unconstrained type. 5718 -- Rule is 4.6(38). 5719 5720 if Nkind (Parent (Ck_Node)) = N_Type_Conversion then 5721 declare 5722 Opnd_Index : Node_Id; 5723 Targ_Index : Node_Id; 5724 5725 begin 5726 Opnd_Index 5727 := First_Index (Get_Actual_Subtype (Ck_Node)); 5728 Targ_Index := First_Index (T_Typ); 5729 5730 while Opnd_Index /= Empty loop 5731 if Nkind (Opnd_Index) = N_Range then 5732 if Is_In_Range 5733 (Low_Bound (Opnd_Index), Etype (Targ_Index)) 5734 and then 5735 Is_In_Range 5736 (High_Bound (Opnd_Index), Etype (Targ_Index)) 5737 then 5738 null; 5739 5740 -- If null range, no check needed. 5741 elsif 5742 Compile_Time_Known_Value (High_Bound (Opnd_Index)) 5743 and then 5744 Compile_Time_Known_Value (Low_Bound (Opnd_Index)) 5745 and then 5746 Expr_Value (High_Bound (Opnd_Index)) < 5747 Expr_Value (Low_Bound (Opnd_Index)) 5748 then 5749 null; 5750 5751 elsif Is_Out_Of_Range 5752 (Low_Bound (Opnd_Index), Etype (Targ_Index)) 5753 or else 5754 Is_Out_Of_Range 5755 (High_Bound (Opnd_Index), Etype (Targ_Index)) 5756 then 5757 Add_Check 5758 (Compile_Time_Constraint_Error 5759 (Wnode, "value out of range of}?", T_Typ)); 5760 5761 else 5762 Evolve_Or_Else 5763 (Cond, 5764 Discrete_Range_Cond 5765 (Opnd_Index, Etype (Targ_Index))); 5766 end if; 5767 end if; 5768 5769 Next_Index (Opnd_Index); 5770 Next_Index (Targ_Index); 5771 end loop; 5772 end; 5773 end if; 5774 end if; 5775 end if; 5776 5777 -- Construct the test and insert into the tree 5778 5779 if Present (Cond) then 5780 if Do_Access then 5781 Cond := Guard_Access (Cond, Loc, Ck_Node); 5782 end if; 5783 5784 Add_Check 5785 (Make_Raise_Constraint_Error (Loc, 5786 Condition => Cond, 5787 Reason => CE_Range_Check_Failed)); 5788 end if; 5789 5790 return Ret_Result; 5791 end Selected_Range_Checks; 5792 5793 ------------------------------- 5794 -- Storage_Checks_Suppressed -- 5795 ------------------------------- 5796 5797 function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is 5798 begin 5799 if Present (E) and then Checks_May_Be_Suppressed (E) then 5800 return Is_Check_Suppressed (E, Storage_Check); 5801 else 5802 return Scope_Suppress (Storage_Check); 5803 end if; 5804 end Storage_Checks_Suppressed; 5805 5806 --------------------------- 5807 -- Tag_Checks_Suppressed -- 5808 --------------------------- 5809 5810 function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is 5811 begin 5812 if Present (E) then 5813 if Kill_Tag_Checks (E) then 5814 return True; 5815 elsif Checks_May_Be_Suppressed (E) then 5816 return Is_Check_Suppressed (E, Tag_Check); 5817 end if; 5818 end if; 5819 5820 return Scope_Suppress (Tag_Check); 5821 end Tag_Checks_Suppressed; 5822 5823end Checks; 5824