gcc/ada/checks.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               C H E C K S                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --          Copyright (C) 1992-2002 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Atree;    use Atree;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Errout;   use Errout;
  32 with Exp_Ch2;  use Exp_Ch2;
  33 with Exp_Util; use Exp_Util;
  34 with Elists;   use Elists;
  35 with Freeze;   use Freeze;
  36 with Nlists;   use Nlists;
  37 with Nmake;    use Nmake;
  38 with Opt;      use Opt;
  39 with Restrict; use Restrict;
  40 with Rtsfind;  use Rtsfind;
  41 with Sem;      use Sem;
  42 with Sem_Eval; use Sem_Eval;
  43 with Sem_Res;  use Sem_Res;
  44 with Sem_Util; use Sem_Util;
  45 with Sem_Warn; use Sem_Warn;
  46 with Sinfo;    use Sinfo;
  47 with Snames;   use Snames;
  48 with Stand;    use Stand;
  49 with Targparm; use Targparm;
  50 with Tbuild;   use Tbuild;
  51 with Ttypes;   use Ttypes;
  52 with Urealp;   use Urealp;
  53 with Validsw;  use Validsw;
  54
  55 package body Checks is
  56
  57    --  General note: many of these routines are concerned with generating
  58    --  checking code to make sure that constraint error is raised at runtime.
  59    --  Clearly this code is only needed if the expander is active, since
  60    --  otherwise we will not be generating code or going into the runtime
  61    --  execution anyway.
  62
  63    --  We therefore disconnect most of these checks if the expander is
  64    --  inactive. This has the additional benefit that we do not need to
  65    --  worry about the tree being messed up by previous errors (since errors
  66    --  turn off expansion anyway).
  67
  68    --  There are a few exceptions to the above rule. For instance routines
  69    --  such as Apply_Scalar_Range_Check that do not insert any code can be
  70    --  safely called even when the Expander is inactive (but Errors_Detected
  71    --  is 0). The benefit of executing this code when expansion is off, is
  72    --  the ability to emit constraint error warning for static expressions
  73    --  even when we are not generating code.
  74
  75    ----------------------------
  76    -- Local Subprogram Specs --
  77    ----------------------------
  78
  79    procedure Apply_Selected_Length_Checks
  80      (Ck_Node    : Node_Id;
  81       Target_Typ : Entity_Id;
  82       Source_Typ : Entity_Id;
  83       Do_Static  : Boolean);
  84    --  This is the subprogram that does all the work for Apply_Length_Check
  85    --  and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
  86    --  described for the above routines. The Do_Static flag indicates that
  87    --  only a static check is to be done.
  88
  89    procedure Apply_Selected_Range_Checks
  90      (Ck_Node    : Node_Id;
  91       Target_Typ : Entity_Id;
  92       Source_Typ : Entity_Id;
  93       Do_Static  : Boolean);
  94    --  This is the subprogram that does all the work for Apply_Range_Check.
  95    --  Expr, Target_Typ and Source_Typ are as described for the above
  96    --  routine. The Do_Static flag indicates that only a static check is
  97    --  to be done.
  98
  99    function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id;
 100    --  If a discriminal is used in constraining a prival, Return reference
 101    --  to the discriminal of the protected body (which renames the parameter
 102    --  of the enclosing protected operation). This clumsy transformation is
 103    --  needed because privals are created too late and their actual subtypes
 104    --  are not available when analysing the bodies of the protected operations.
 105    --  To be cleaned up???
 106
 107    function Guard_Access
 108      (Cond    : Node_Id;
 109       Loc     : Source_Ptr;
 110       Ck_Node : Node_Id)
 111       return    Node_Id;
 112    --  In the access type case, guard the test with a test to ensure
 113    --  that the access value is non-null, since the checks do not
 114    --  not apply to null access values.
 115
 116    procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr);
 117    --  Called by Apply_{Length,Range}_Checks to rewrite the tree with the
 118    --  Constraint_Error node.
 119
 120    function Selected_Length_Checks
 121      (Ck_Node    : Node_Id;
 122       Target_Typ : Entity_Id;
 123       Source_Typ : Entity_Id;
 124       Warn_Node  : Node_Id)
 125       return       Check_Result;
 126    --  Like Apply_Selected_Length_Checks, except it doesn't modify
 127    --  anything, just returns a list of nodes as described in the spec of
 128    --  this package for the Range_Check function.
 129
 130    function Selected_Range_Checks
 131      (Ck_Node    : Node_Id;
 132       Target_Typ : Entity_Id;
 133       Source_Typ : Entity_Id;
 134       Warn_Node  : Node_Id)
 135       return       Check_Result;
 136    --  Like Apply_Selected_Range_Checks, except it doesn't modify anything,
 137    --  just returns a list of nodes as described in the spec of this package
 138    --  for the Range_Check function.
 139
 140    ------------------------------
 141    -- Access_Checks_Suppressed --
 142    ------------------------------
 143
 144    function Access_Checks_Suppressed (E : Entity_Id) return Boolean is
 145    begin
 146       return Scope_Suppress.Access_Checks
 147         or else (Present (E) and then Suppress_Access_Checks (E));
 148    end Access_Checks_Suppressed;
 149
 150    -------------------------------------
 151    -- Accessibility_Checks_Suppressed --
 152    -------------------------------------
 153
 154    function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is
 155    begin
 156       return Scope_Suppress.Accessibility_Checks
 157         or else (Present (E) and then Suppress_Accessibility_Checks (E));
 158    end Accessibility_Checks_Suppressed;
 159
 160    -------------------------
 161    -- Append_Range_Checks --
 162    -------------------------
 163
 164    procedure Append_Range_Checks
 165      (Checks       : Check_Result;
 166       Stmts        : List_Id;
 167       Suppress_Typ : Entity_Id;
 168       Static_Sloc  : Source_Ptr;
 169       Flag_Node    : Node_Id)
 170    is
 171       Internal_Flag_Node   : Node_Id    := Flag_Node;
 172       Internal_Static_Sloc : Source_Ptr := Static_Sloc;
 173       Checks_On : constant Boolean :=
 174                     (not Index_Checks_Suppressed (Suppress_Typ))
 175                        or else
 176                     (not Range_Checks_Suppressed (Suppress_Typ));
 177
 178    begin
 179       --  For now we just return if Checks_On is false, however this should
 180       --  be enhanced to check for an always True value in the condition
 181       --  and to generate a compilation warning???
 182
 183       if not Checks_On then
 184          return;
 185       end if;
 186
 187       for J in 1 .. 2 loop
 188          exit when No (Checks (J));
 189
 190          if Nkind (Checks (J)) = N_Raise_Constraint_Error
 191            and then Present (Condition (Checks (J)))
 192          then
 193             if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
 194                Append_To (Stmts, Checks (J));
 195                Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
 196             end if;
 197
 198          else
 199             Append_To
 200               (Stmts,
 201                 Make_Raise_Constraint_Error (Internal_Static_Sloc,
 202                   Reason => CE_Range_Check_Failed));
 203          end if;
 204       end loop;
 205    end Append_Range_Checks;
 206
 207    ------------------------
 208    -- Apply_Access_Check --
 209    ------------------------
 210
 211    procedure Apply_Access_Check (N : Node_Id) is
 212       P : constant Node_Id := Prefix (N);
 213
 214    begin
 215       if Inside_A_Generic then
 216          return;
 217       end if;
 218
 219       if Is_Entity_Name (P) then
 220          Check_Unset_Reference (P);
 221       end if;
 222
 223       if Is_Entity_Name (P)
 224         and then Access_Checks_Suppressed (Entity (P))
 225       then
 226          return;
 227
 228       elsif Access_Checks_Suppressed (Etype (P)) then
 229          return;
 230
 231       else
 232          Set_Do_Access_Check (N, True);
 233       end if;
 234    end Apply_Access_Check;
 235
 236    -------------------------------
 237    -- Apply_Accessibility_Check --
 238    -------------------------------
 239
 240    procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id) is
 241       Loc         : constant Source_Ptr := Sloc (N);
 242       Param_Ent   : constant Entity_Id  := Param_Entity (N);
 243       Param_Level : Node_Id;
 244       Type_Level  : Node_Id;
 245
 246    begin
 247       if Inside_A_Generic then
 248          return;
 249
 250       --  Only apply the run-time check if the access parameter
 251       --  has an associated extra access level parameter and
 252       --  when the level of the type is less deep than the level
 253       --  of the access parameter.
 254
 255       elsif Present (Param_Ent)
 256          and then Present (Extra_Accessibility (Param_Ent))
 257          and then UI_Gt (Object_Access_Level (N),
 258                          Type_Access_Level (Typ))
 259          and then not Accessibility_Checks_Suppressed (Param_Ent)
 260          and then not Accessibility_Checks_Suppressed (Typ)
 261       then
 262          Param_Level :=
 263            New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);
 264
 265          Type_Level :=
 266            Make_Integer_Literal (Loc, Type_Access_Level (Typ));
 267
 268          --  Raise Program_Error if the accessibility level of the
 269          --  the access parameter is deeper than the level of the
 270          --  target access type.
 271
 272          Insert_Action (N,
 273            Make_Raise_Program_Error (Loc,
 274              Condition =>
 275                Make_Op_Gt (Loc,
 276                  Left_Opnd  => Param_Level,
 277                  Right_Opnd => Type_Level),
 278              Reason => PE_Accessibility_Check_Failed));
 279
 280          Analyze_And_Resolve (N);
 281       end if;
 282    end Apply_Accessibility_Check;
 283
 284    ---------------------------
 285    -- Apply_Alignment_Check --
 286    ---------------------------
 287
 288    procedure Apply_Alignment_Check (E : Entity_Id; N : Node_Id) is
 289       AC   : constant Node_Id := Address_Clause (E);
 290       Expr : Node_Id;
 291       Loc  : Source_Ptr;
 292
 293    begin
 294       if No (AC) or else Range_Checks_Suppressed (E) then
 295          return;
 296       end if;
 297
 298       Loc  := Sloc (AC);
 299       Expr := Expression (AC);
 300
 301       if Nkind (Expr) = N_Unchecked_Type_Conversion then
 302          Expr := Expression (Expr);
 303
 304       elsif Nkind (Expr) = N_Function_Call
 305         and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
 306       then
 307          Expr := First (Parameter_Associations (Expr));
 308
 309          if Nkind (Expr) = N_Parameter_Association then
 310             Expr := Explicit_Actual_Parameter (Expr);
 311          end if;
 312       end if;
 313
 314       --  Here Expr is the address value. See if we know that the
 315       --  value is unacceptable at compile time.
 316
 317       if Compile_Time_Known_Value (Expr)
 318         and then Known_Alignment (E)
 319       then
 320          if Expr_Value (Expr) mod Alignment (E) /= 0 then
 321             Insert_Action (N,
 322                Make_Raise_Program_Error (Loc,
 323                  Reason => PE_Misaligned_Address_Value));
 324             Error_Msg_NE
 325               ("?specified address for& not " &
 326                "consistent with alignment", Expr, E);
 327          end if;
 328
 329       --  Here we do not know if the value is acceptable, generate
 330       --  code to raise PE if alignment is inappropriate.
 331
 332       else
 333          --  Skip generation of this code if we don't want elab code
 334
 335          if not Restrictions (No_Elaboration_Code) then
 336             Insert_After_And_Analyze (N,
 337               Make_Raise_Program_Error (Loc,
 338                 Condition =>
 339                   Make_Op_Ne (Loc,
 340                     Left_Opnd =>
 341                       Make_Op_Mod (Loc,
 342                         Left_Opnd =>
 343                           Unchecked_Convert_To
 344                            (RTE (RE_Integer_Address),
 345                             Duplicate_Subexpr (Expr)),
 346                         Right_Opnd =>
 347                           Make_Attribute_Reference (Loc,
 348                             Prefix => New_Occurrence_Of (E, Loc),
 349                             Attribute_Name => Name_Alignment)),
 350                     Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
 351                 Reason => PE_Misaligned_Address_Value),
 352               Suppress => All_Checks);
 353          end if;
 354       end if;
 355
 356       return;
 357    end Apply_Alignment_Check;
 358
 359    -------------------------------------
 360    -- Apply_Arithmetic_Overflow_Check --
 361    -------------------------------------
 362
 363    --  This routine is called only if the type is an integer type, and
 364    --  a software arithmetic overflow check must be performed for op
 365    --  (add, subtract, multiply). The check is performed only if
 366    --  Software_Overflow_Checking is enabled and Do_Overflow_Check
 367    --  is set. In this case we expand the operation into a more complex
 368    --  sequence of tests that ensures that overflow is properly caught.
 369
 370    procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is
 371       Loc   : constant Source_Ptr := Sloc (N);
 372       Typ   : constant Entity_Id  := Etype (N);
 373       Rtyp  : constant Entity_Id  := Root_Type (Typ);
 374       Siz   : constant Int        := UI_To_Int (Esize (Rtyp));
 375       Dsiz  : constant Int        := Siz * 2;
 376       Opnod : Node_Id;
 377       Ctyp  : Entity_Id;
 378       Opnd  : Node_Id;
 379       Cent  : RE_Id;
 380       Lo    : Uint;
 381       Hi    : Uint;
 382       OK    : Boolean;
 383
 384    begin
 385       if Backend_Overflow_Checks_On_Target
 386         or not Do_Overflow_Check (N)
 387         or not Expander_Active
 388       then
 389          return;
 390       end if;
 391
 392       --  Nothing to do if the range of the result is known OK
 393
 394       Determine_Range (N, OK, Lo, Hi);
 395
 396       --  Note in the test below that we assume that if a bound of the
 397       --  range is equal to that of the type. That's not quite accurate
 398       --  but we do this for the following reasons:
 399
 400       --   a) The way that Determine_Range works, it will typically report
 401       --      the bounds of the value are the bounds of the type, because
 402       --      it either can't tell anything more precise, or does not think
 403       --      it is worth the effort to be more precise.
 404
 405       --   b) It is very unusual to have a situation in which this would
 406       --      generate an unnecessary overflow check (an example would be
 407       --      a subtype with a range 0 .. Integer'Last - 1 to which the
 408       --      literal value one is added.
 409
 410       --   c) The alternative is a lot of special casing in this routine
 411       --      which would partially duplicate the Determine_Range processing.
 412
 413       if OK
 414         and then Lo > Expr_Value (Type_Low_Bound  (Typ))
 415         and then Hi < Expr_Value (Type_High_Bound (Typ))
 416       then
 417          return;
 418       end if;
 419
 420       --  None of the special case optimizations worked, so there is nothing
 421       --  for it but to generate the full general case code:
 422
 423       --    x op y
 424
 425       --  is expanded into
 426
 427       --    Typ (Checktyp (x) op Checktyp (y));
 428
 429       --  where Typ is the type of the original expression, and Checktyp is
 430       --  an integer type of sufficient length to hold the largest possible
 431       --  result.
 432
 433       --  In the case where check type exceeds the size of Long_Long_Integer,
 434       --  we use a different approach, expanding to:
 435
 436       --    typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
 437
 438       --  where xxx is Add, Multiply or Subtract as appropriate
 439
 440       --  Find check type if one exists
 441
 442       if Dsiz <= Standard_Integer_Size then
 443          Ctyp := Standard_Integer;
 444
 445       elsif Dsiz <= Standard_Long_Long_Integer_Size then
 446          Ctyp := Standard_Long_Long_Integer;
 447
 448       --  No check type exists, use runtime call
 449
 450       else
 451          if Nkind (N) = N_Op_Add then
 452             Cent := RE_Add_With_Ovflo_Check;
 453
 454          elsif Nkind (N) = N_Op_Multiply then
 455             Cent := RE_Multiply_With_Ovflo_Check;
 456
 457          else
 458             pragma Assert (Nkind (N) = N_Op_Subtract);
 459             Cent := RE_Subtract_With_Ovflo_Check;
 460          end if;
 461
 462          Rewrite (N,
 463            OK_Convert_To (Typ,
 464              Make_Function_Call (Loc,
 465                Name => New_Reference_To (RTE (Cent), Loc),
 466                Parameter_Associations => New_List (
 467                  OK_Convert_To (RTE (RE_Integer_64), Left_Opnd  (N)),
 468                  OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N))))));
 469
 470          Analyze_And_Resolve (N, Typ);
 471          return;
 472       end if;
 473
 474       --  If we fall through, we have the case where we do the arithmetic in
 475       --  the next higher type and get the check by conversion. In these cases
 476       --  Ctyp is set to the type to be used as the check type.
 477
 478       Opnod := Relocate_Node (N);
 479
 480       Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod));
 481
 482       Analyze (Opnd);
 483       Set_Etype (Opnd, Ctyp);
 484       Set_Analyzed (Opnd, True);
 485       Set_Left_Opnd (Opnod, Opnd);
 486
 487       Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod));
 488
 489       Analyze (Opnd);
 490       Set_Etype (Opnd, Ctyp);
 491       Set_Analyzed (Opnd, True);
 492       Set_Right_Opnd (Opnod, Opnd);
 493
 494       --  The type of the operation changes to the base type of the check
 495       --  type, and we reset the overflow check indication, since clearly
 496       --  no overflow is possible now that we are using a double length
 497       --  type. We also set the Analyzed flag to avoid a recursive attempt
 498       --  to expand the node.
 499
 500       Set_Etype             (Opnod, Base_Type (Ctyp));
 501       Set_Do_Overflow_Check (Opnod, False);
 502       Set_Analyzed          (Opnod, True);
 503
 504       --  Now build the outer conversion
 505
 506       Opnd := OK_Convert_To (Typ, Opnod);
 507
 508       Analyze (Opnd);
 509       Set_Etype (Opnd, Typ);
 510       Set_Analyzed (Opnd, True);
 511       Set_Do_Overflow_Check (Opnd, True);
 512
 513       Rewrite (N, Opnd);
 514    end Apply_Arithmetic_Overflow_Check;
 515
 516    ----------------------------
 517    -- Apply_Array_Size_Check --
 518    ----------------------------
 519
 520    --  Note: Really of course this entre check should be in the backend,
 521    --  and perhaps this is not quite the right value, but it is good
 522    --  enough to catch the normal cases (and the relevant ACVC tests!)
 523
 524    procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is
 525       Loc  : constant Source_Ptr := Sloc (N);
 526       Ctyp : constant Entity_Id  := Component_Type (Typ);
 527       Ent  : constant Entity_Id  := Defining_Identifier (N);
 528       Decl : Node_Id;
 529       Lo   : Node_Id;
 530       Hi   : Node_Id;
 531       Lob  : Uint;
 532       Hib  : Uint;
 533       Siz  : Uint;
 534       Xtyp : Entity_Id;
 535       Indx : Node_Id;
 536       Sizx : Node_Id;
 537       Code : Node_Id;
 538
 539       Static : Boolean := True;
 540       --  Set false if any index subtye bound is non-static
 541
 542       Umark : constant Uintp.Save_Mark := Uintp.Mark;
 543       --  We can throw away all the Uint computations here, since they are
 544       --  done only to generate boolean test results.
 545
 546       Check_Siz : Uint;
 547       --  Size to check against
 548
 549       function Is_Address_Or_Import (Decl : Node_Id) return Boolean;
 550       --  Determines if Decl is an address clause or Import/Interface pragma
 551       --  that references the defining identifier of the current declaration.
 552
 553       --------------------------
 554       -- Is_Address_Or_Import --
 555       --------------------------
 556
 557       function Is_Address_Or_Import (Decl : Node_Id) return Boolean is
 558       begin
 559          if Nkind (Decl) = N_At_Clause then
 560             return Chars (Identifier (Decl)) = Chars (Ent);
 561
 562          elsif Nkind (Decl) = N_Attribute_Definition_Clause then
 563             return
 564               Chars (Decl) = Name_Address
 565                 and then
 566               Nkind (Name (Decl)) = N_Identifier
 567                 and then
 568               Chars (Name (Decl)) = Chars (Ent);
 569
 570          elsif Nkind (Decl) = N_Pragma then
 571             if (Chars (Decl) = Name_Import
 572                  or else
 573                 Chars (Decl) = Name_Interface)
 574               and then Present (Pragma_Argument_Associations (Decl))
 575             then
 576                declare
 577                   F : constant Node_Id :=
 578                         First (Pragma_Argument_Associations (Decl));
 579
 580                begin
 581                   return
 582                     Present (F)
 583                       and then
 584                     Present (Next (F))
 585                       and then
 586                     Nkind (Expression (Next (F))) = N_Identifier
 587                       and then
 588                     Chars (Expression (Next (F))) = Chars (Ent);
 589                end;
 590
 591             else
 592                return False;
 593             end if;
 594
 595          else
 596             return False;
 597          end if;
 598       end Is_Address_Or_Import;
 599
 600    --  Start of processing for Apply_Array_Size_Check
 601
 602    begin
 603       if not Expander_Active
 604         or else Storage_Checks_Suppressed (Typ)
 605       then
 606          return;
 607       end if;
 608
 609       --  It is pointless to insert this check inside an _init_proc, because
 610       --  that's too late, we have already built the object to be the right
 611       --  size, and if it's too large, too bad!
 612
 613       if Inside_Init_Proc then
 614          return;
 615       end if;
 616
 617       --  Look head for pragma interface/import or address clause applying
 618       --  to this entity. If found, we suppress the check entirely. For now
 619       --  we only look ahead 20 declarations to stop this becoming too slow
 620       --  Note that eventually this whole routine gets moved to gigi.
 621
 622       Decl := N;
 623       for Ctr in 1 .. 20 loop
 624          Next (Decl);
 625          exit when No (Decl);
 626
 627          if Is_Address_Or_Import (Decl) then
 628             return;
 629          end if;
 630       end loop;
 631
 632       --  First step is to calculate the maximum number of elements. For this
 633       --  calculation, we use the actual size of the subtype if it is static,
 634       --  and if a bound of a subtype is non-static, we go to the bound of the
 635       --  base type.
 636
 637       Siz := Uint_1;
 638       Indx := First_Index (Typ);
 639       while Present (Indx) loop
 640          Xtyp := Etype (Indx);
 641          Lo := Type_Low_Bound (Xtyp);
 642          Hi := Type_High_Bound (Xtyp);
 643
 644          --  If any bound raises constraint error, we will never get this
 645          --  far, so there is no need to generate any kind of check.
 646
 647          if Raises_Constraint_Error (Lo)
 648               or else
 649             Raises_Constraint_Error (Hi)
 650          then
 651             Uintp.Release (Umark);
 652             return;
 653          end if;
 654
 655          --  Otherwise get bounds values
 656
 657          if Is_Static_Expression (Lo) then
 658             Lob := Expr_Value (Lo);
 659          else
 660             Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp)));
 661             Static := False;
 662          end if;
 663
 664          if Is_Static_Expression (Hi) then
 665             Hib := Expr_Value (Hi);
 666          else
 667             Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp)));
 668             Static := False;
 669          end if;
 670
 671          Siz := Siz *  UI_Max (Hib - Lob + 1, Uint_0);
 672          Next_Index (Indx);
 673       end loop;
 674
 675       --  Compute the limit against which we want to check. For subprograms,
 676       --  where the array will go on the stack, we use 8*2**24, which (in
 677       --  bits) is the size of a 16 megabyte array.
 678
 679       if Is_Subprogram (Scope (Ent)) then
 680          Check_Siz := Uint_2 ** 27;
 681       else
 682          Check_Siz := Uint_2 ** 31;
 683       end if;
 684
 685       --  If we have all static bounds and Siz is too large, then we know we
 686       --  know we have a storage error right now, so generate message
 687
 688       if Static and then Siz >= Check_Siz then
 689          Insert_Action (N,
 690            Make_Raise_Storage_Error (Loc,
 691              Reason => SE_Object_Too_Large));
 692          Warn_On_Instance := True;
 693          Error_Msg_N ("?Storage_Error will be raised at run-time", N);
 694          Warn_On_Instance := False;
 695          Uintp.Release (Umark);
 696          return;
 697       end if;
 698
 699       --  Case of component size known at compile time. If the array
 700       --  size is definitely in range, then we do not need a check.
 701
 702       if Known_Esize (Ctyp)
 703         and then Siz * Esize (Ctyp) < Check_Siz
 704       then
 705          Uintp.Release (Umark);
 706          return;
 707       end if;
 708
 709       --  Here if a dynamic check is required
 710
 711       --  What we do is to build an expression for the size of the array,
 712       --  which is computed as the 'Size of the array component, times
 713       --  the size of each dimension.
 714
 715       Uintp.Release (Umark);
 716
 717       Sizx :=
 718         Make_Attribute_Reference (Loc,
 719           Prefix => New_Occurrence_Of (Ctyp, Loc),
 720           Attribute_Name => Name_Size);
 721
 722       Indx := First_Index (Typ);
 723
 724       for J in 1 .. Number_Dimensions (Typ) loop
 725
 726          if Sloc (Etype (Indx)) = Sloc (N) then
 727             Ensure_Defined (Etype (Indx), N);
 728          end if;
 729
 730          Sizx :=
 731            Make_Op_Multiply (Loc,
 732              Left_Opnd  => Sizx,
 733              Right_Opnd =>
 734                Make_Attribute_Reference (Loc,
 735                  Prefix => New_Occurrence_Of (Typ, Loc),
 736                  Attribute_Name => Name_Length,
 737                  Expressions => New_List (
 738                    Make_Integer_Literal (Loc, J))));
 739          Next_Index (Indx);
 740       end loop;
 741
 742       Code :=
 743         Make_Raise_Storage_Error (Loc,
 744           Condition =>
 745             Make_Op_Ge (Loc,
 746               Left_Opnd  => Sizx,
 747               Right_Opnd =>
 748                 Make_Integer_Literal (Loc, Check_Siz)),
 749             Reason => SE_Object_Too_Large);
 750
 751       Set_Size_Check_Code (Defining_Identifier (N), Code);
 752       Insert_Action (N, Code);
 753    end Apply_Array_Size_Check;
 754
 755    ----------------------------
 756    -- Apply_Constraint_Check --
 757    ----------------------------
 758
 759    procedure Apply_Constraint_Check
 760      (N          : Node_Id;
 761       Typ        : Entity_Id;
 762       No_Sliding : Boolean := False)
 763    is
 764       Desig_Typ : Entity_Id;
 765
 766    begin
 767       if Inside_A_Generic then
 768          return;
 769
 770       elsif Is_Scalar_Type (Typ) then
 771          Apply_Scalar_Range_Check (N, Typ);
 772
 773       elsif Is_Array_Type (Typ) then
 774
 775          --  A useful optimization: an aggregate with only an Others clause
 776          --  always has the right bounds.
 777
 778          if Nkind (N) = N_Aggregate
 779            and then No (Expressions (N))
 780            and then Nkind
 781             (First (Choices (First (Component_Associations (N)))))
 782               = N_Others_Choice
 783          then
 784             return;
 785          end if;
 786
 787          if Is_Constrained (Typ) then
 788             Apply_Length_Check (N, Typ);
 789
 790             if No_Sliding then
 791                Apply_Range_Check (N, Typ);
 792             end if;
 793          else
 794             Apply_Range_Check (N, Typ);
 795          end if;
 796
 797       elsif (Is_Record_Type (Typ)
 798                or else Is_Private_Type (Typ))
 799         and then Has_Discriminants (Base_Type (Typ))
 800         and then Is_Constrained (Typ)
 801       then
 802          Apply_Discriminant_Check (N, Typ);
 803
 804       elsif Is_Access_Type (Typ) then
 805
 806          Desig_Typ := Designated_Type (Typ);
 807
 808          --  No checks necessary if expression statically null
 809
 810          if Nkind (N) = N_Null then
 811             null;
 812
 813          --  No sliding possible on access to arrays
 814
 815          elsif Is_Array_Type (Desig_Typ) then
 816             if Is_Constrained (Desig_Typ) then
 817                Apply_Length_Check (N, Typ);
 818             end if;
 819
 820             Apply_Range_Check (N, Typ);
 821
 822          elsif Has_Discriminants (Base_Type (Desig_Typ))
 823             and then Is_Constrained (Desig_Typ)
 824          then
 825             Apply_Discriminant_Check (N, Typ);
 826          end if;
 827       end if;
 828    end Apply_Constraint_Check;
 829
 830    ------------------------------
 831    -- Apply_Discriminant_Check --
 832    ------------------------------
 833
 834    procedure Apply_Discriminant_Check
 835      (N   : Node_Id;
 836       Typ : Entity_Id;
 837       Lhs : Node_Id := Empty)
 838    is
 839       Loc       : constant Source_Ptr := Sloc (N);
 840       Do_Access : constant Boolean    := Is_Access_Type (Typ);
 841       S_Typ     : Entity_Id  := Etype (N);
 842       Cond      : Node_Id;
 843       T_Typ     : Entity_Id;
 844
 845       function Is_Aliased_Unconstrained_Component return Boolean;
 846       --  It is possible for an aliased component to have a nominal
 847       --  unconstrained subtype (through instantiation). If this is a
 848       --  discriminated component assigned in the expansion of an aggregate
 849       --  in an initialization, the check must be suppressed. This unusual
 850       --  situation requires a predicate of its own (see 7503-008).
 851
 852       ----------------------------------------
 853       -- Is_Aliased_Unconstrained_Component --
 854       ----------------------------------------
 855
 856       function Is_Aliased_Unconstrained_Component return Boolean is
 857          Comp : Entity_Id;
 858          Pref : Node_Id;
 859
 860       begin
 861          if Nkind (Lhs) /= N_Selected_Component then
 862             return False;
 863          else
 864             Comp := Entity (Selector_Name (Lhs));
 865             Pref := Prefix (Lhs);
 866          end if;
 867
 868          if Ekind (Comp) /= E_Component
 869            or else not Is_Aliased (Comp)
 870          then
 871             return False;
 872          end if;
 873
 874          return not Comes_From_Source (Pref)
 875            and then In_Instance
 876            and then not Is_Constrained (Etype (Comp));
 877       end Is_Aliased_Unconstrained_Component;
 878
 879    --  Start of processing for Apply_Discriminant_Check
 880
 881    begin
 882       if Do_Access then
 883          T_Typ := Designated_Type (Typ);
 884       else
 885          T_Typ := Typ;
 886       end if;
 887
 888       --  Nothing to do if discriminant checks are suppressed or else no code
 889       --  is to be generated
 890
 891       if not Expander_Active
 892         or else Discriminant_Checks_Suppressed (T_Typ)
 893       then
 894          return;
 895       end if;
 896
 897       --  No discriminant checks necessary for access when expression
 898       --  is statically Null. This is not only an optimization, this is
 899       --  fundamental because otherwise discriminant checks may be generated
 900       --  in init procs for types containing an access to a non-frozen yet
 901       --  record, causing a deadly forward reference.
 902
 903       --  Also, if the expression is of an access type whose designated
 904       --  type is incomplete, then the access value must be null and
 905       --  we suppress the check.
 906
 907       if Nkind (N) = N_Null then
 908          return;
 909
 910       elsif Is_Access_Type (S_Typ) then
 911          S_Typ := Designated_Type (S_Typ);
 912
 913          if Ekind (S_Typ) = E_Incomplete_Type then
 914             return;
 915          end if;
 916       end if;
 917
 918       --  If an assignment target is present, then we need to generate
 919       --  the actual subtype if the target is a parameter or aliased
 920       --  object with an unconstrained nominal subtype.
 921
 922       if Present (Lhs)
 923         and then (Present (Param_Entity (Lhs))
 924                    or else (not Is_Constrained (T_Typ)
 925                              and then Is_Aliased_View (Lhs)
 926                              and then not Is_Aliased_Unconstrained_Component))
 927       then
 928          T_Typ := Get_Actual_Subtype (Lhs);
 929       end if;
 930
 931       --  Nothing to do if the type is unconstrained (this is the case
 932       --  where the actual subtype in the RM sense of N is unconstrained
 933       --  and no check is required).
 934
 935       if not Is_Constrained (T_Typ) then
 936          return;
 937       end if;
 938
 939       --  Suppress checks if the subtypes are the same.
 940       --  the check must be preserved in an assignment to a formal, because
 941       --  the constraint is given by the actual.
 942
 943       if Nkind (Original_Node (N)) /= N_Allocator
 944         and then (No (Lhs)
 945           or else not Is_Entity_Name (Lhs)
 946           or else (Ekind (Entity (Lhs)) /=  E_In_Out_Parameter
 947                     and then Ekind (Entity (Lhs)) /=  E_Out_Parameter))
 948       then
 949          if (Etype (N) = Typ
 950               or else (Do_Access and then Designated_Type (Typ) = S_Typ))
 951            and then not Is_Aliased_View (Lhs)
 952          then
 953             return;
 954          end if;
 955
 956       --  We can also eliminate checks on allocators with a subtype mark
 957       --  that coincides with the context type. The context type may be a
 958       --  subtype without a constraint (common case, a generic actual).
 959
 960       elsif Nkind (Original_Node (N)) = N_Allocator
 961         and then Is_Entity_Name (Expression (Original_Node (N)))
 962       then
 963          declare
 964             Alloc_Typ : Entity_Id := Entity (Expression (Original_Node (N)));
 965
 966          begin
 967             if Alloc_Typ = T_Typ
 968               or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration
 969                         and then Is_Entity_Name (
 970                           Subtype_Indication (Parent (T_Typ)))
 971                         and then Alloc_Typ = Base_Type (T_Typ))
 972
 973             then
 974                return;
 975             end if;
 976          end;
 977       end if;
 978
 979       --  See if we have a case where the types are both constrained, and
 980       --  all the constraints are constants. In this case, we can do the
 981       --  check successfully at compile time.
 982
 983       --  we skip this check for the case where the node is a rewritten`
 984       --  allocator, because it already carries the context subtype, and
 985       --  extracting the discriminants from the aggregate is messy.
 986
 987       if Is_Constrained (S_Typ)
 988         and then Nkind (Original_Node (N)) /= N_Allocator
 989       then
 990          declare
 991             DconT : Elmt_Id;
 992             Discr : Entity_Id;
 993             DconS : Elmt_Id;
 994             ItemS : Node_Id;
 995             ItemT : Node_Id;
 996
 997          begin
 998             --  S_Typ may not have discriminants in the case where it is a
 999             --  private type completed by a default discriminated type. In
1000             --  that case, we need to get the constraints from the
1001             --  underlying_type. If the underlying type is unconstrained (i.e.
1002             --  has no default discriminants) no check is needed.
1003
1004             if Has_Discriminants (S_Typ) then
1005                Discr := First_Discriminant (S_Typ);
1006                DconS := First_Elmt (Discriminant_Constraint (S_Typ));
1007
1008             else
1009                Discr := First_Discriminant (Underlying_Type (S_Typ));
1010                DconS :=
1011                  First_Elmt
1012                    (Discriminant_Constraint (Underlying_Type (S_Typ)));
1013
1014                if No (DconS) then
1015                   return;
1016                end if;
1017             end if;
1018
1019             DconT  := First_Elmt (Discriminant_Constraint (T_Typ));
1020
1021             while Present (Discr) loop
1022                ItemS := Node (DconS);
1023                ItemT := Node (DconT);
1024
1025                exit when
1026                  not Is_OK_Static_Expression (ItemS)
1027                    or else
1028                  not Is_OK_Static_Expression (ItemT);
1029
1030                if Expr_Value (ItemS) /= Expr_Value (ItemT) then
1031                   if Do_Access then   --  needs run-time check.
1032                      exit;
1033                   else
1034                      Apply_Compile_Time_Constraint_Error
1035                        (N, "incorrect value for discriminant&?",
1036                         CE_Discriminant_Check_Failed, Ent => Discr);
1037                      return;
1038                   end if;
1039                end if;
1040
1041                Next_Elmt (DconS);
1042                Next_Elmt (DconT);
1043                Next_Discriminant (Discr);
1044             end loop;
1045
1046             if No (Discr) then
1047                return;
1048             end if;
1049          end;
1050       end if;
1051
1052       --  Here we need a discriminant check. First build the expression
1053       --  for the comparisons of the discriminants:
1054
1055       --    (n.disc1 /= typ.disc1) or else
1056       --    (n.disc2 /= typ.disc2) or else
1057       --     ...
1058       --    (n.discn /= typ.discn)
1059
1060       Cond := Build_Discriminant_Checks (N, T_Typ);
1061
1062       --  If Lhs is set and is a parameter, then the condition is
1063       --  guarded by: lhs'constrained and then (condition built above)
1064
1065       if Present (Param_Entity (Lhs)) then
1066          Cond :=
1067            Make_And_Then (Loc,
1068              Left_Opnd =>
1069                Make_Attribute_Reference (Loc,
1070                  Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc),
1071                  Attribute_Name => Name_Constrained),
1072              Right_Opnd => Cond);
1073       end if;
1074
1075       if Do_Access then
1076          Cond := Guard_Access (Cond, Loc, N);
1077       end if;
1078
1079       Insert_Action (N,
1080         Make_Raise_Constraint_Error (Loc,
1081           Condition => Cond,
1082           Reason    => CE_Discriminant_Check_Failed));
1083
1084    end Apply_Discriminant_Check;
1085
1086    ------------------------
1087    -- Apply_Divide_Check --
1088    ------------------------
1089
1090    procedure Apply_Divide_Check (N : Node_Id) is
1091       Loc   : constant Source_Ptr := Sloc (N);
1092       Typ   : constant Entity_Id  := Etype (N);
1093       Left  : constant Node_Id    := Left_Opnd (N);
1094       Right : constant Node_Id    := Right_Opnd (N);
1095
1096       LLB : Uint;
1097       Llo : Uint;
1098       Lhi : Uint;
1099       LOK : Boolean;
1100       Rlo : Uint;
1101       Rhi : Uint;
1102       ROK : Boolean;
1103
1104    begin
1105       if Expander_Active
1106         and not Backend_Divide_Checks_On_Target
1107       then
1108          Determine_Range (Right, ROK, Rlo, Rhi);
1109
1110          --  See if division by zero possible, and if so generate test. This
1111          --  part of the test is not controlled by the -gnato switch.
1112
1113          if Do_Division_Check (N) then
1114
1115             if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
1116                Insert_Action (N,
1117                  Make_Raise_Constraint_Error (Loc,
1118                    Condition =>
1119                      Make_Op_Eq (Loc,
1120                        Left_Opnd => Duplicate_Subexpr (Right),
1121                        Right_Opnd => Make_Integer_Literal (Loc, 0)),
1122                    Reason => CE_Divide_By_Zero));
1123             end if;
1124          end if;
1125
1126          --  Test for extremely annoying case of xxx'First divided by -1
1127
1128          if Do_Overflow_Check (N) then
1129
1130             if Nkind (N) = N_Op_Divide
1131               and then Is_Signed_Integer_Type (Typ)
1132             then
1133                Determine_Range (Left, LOK, Llo, Lhi);
1134                LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
1135
1136                if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
1137                  and then
1138                  ((not LOK) or else (Llo = LLB))
1139                then
1140                   Insert_Action (N,
1141                     Make_Raise_Constraint_Error (Loc,
1142                       Condition =>
1143                         Make_And_Then (Loc,
1144
1145                            Make_Op_Eq (Loc,
1146                              Left_Opnd  => Duplicate_Subexpr (Left),
1147                              Right_Opnd => Make_Integer_Literal (Loc, LLB)),
1148
1149                            Make_Op_Eq (Loc,
1150                              Left_Opnd => Duplicate_Subexpr (Right),
1151                              Right_Opnd =>
1152                                Make_Integer_Literal (Loc, -1))),
1153                       Reason => CE_Overflow_Check_Failed));
1154                end if;
1155             end if;
1156          end if;
1157       end if;
1158    end Apply_Divide_Check;
1159
1160    ------------------------
1161    -- Apply_Length_Check --
1162    ------------------------
1163
1164    procedure Apply_Length_Check
1165      (Ck_Node    : Node_Id;
1166       Target_Typ : Entity_Id;
1167       Source_Typ : Entity_Id := Empty)
1168    is
1169    begin
1170       Apply_Selected_Length_Checks
1171         (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
1172    end Apply_Length_Check;
1173
1174    -----------------------
1175    -- Apply_Range_Check --
1176    -----------------------
1177
1178    procedure Apply_Range_Check
1179      (Ck_Node    : Node_Id;
1180       Target_Typ : Entity_Id;
1181       Source_Typ : Entity_Id := Empty)
1182    is
1183    begin
1184       Apply_Selected_Range_Checks
1185         (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
1186    end Apply_Range_Check;
1187
1188    ------------------------------
1189    -- Apply_Scalar_Range_Check --
1190    ------------------------------
1191
1192    --  Note that Apply_Scalar_Range_Check never turns the Do_Range_Check
1193    --  flag off if it is already set on.
1194
1195    procedure Apply_Scalar_Range_Check
1196      (Expr       : Node_Id;
1197       Target_Typ : Entity_Id;
1198       Source_Typ : Entity_Id := Empty;
1199       Fixed_Int  : Boolean   := False)
1200    is
1201       Parnt   : constant Node_Id := Parent (Expr);
1202       S_Typ   : Entity_Id;
1203       Arr     : Node_Id   := Empty;  -- initialize to prevent warning
1204       Arr_Typ : Entity_Id := Empty;  -- initialize to prevent warning
1205       OK      : Boolean;
1206
1207       Is_Subscr_Ref : Boolean;
1208       --  Set true if Expr is a subscript
1209
1210       Is_Unconstrained_Subscr_Ref : Boolean;
1211       --  Set true if Expr is a subscript of an unconstrained array. In this
1212       --  case we do not attempt to do an analysis of the value against the
1213       --  range of the subscript, since we don't know the actual subtype.
1214
1215       Int_Real : Boolean;
1216       --  Set to True if Expr should be regarded as a real value
1217       --  even though the type of Expr might be discrete.
1218
1219       procedure Bad_Value;
1220       --  Procedure called if value is determined to be out of range
1221
1222       procedure Bad_Value is
1223       begin
1224          Apply_Compile_Time_Constraint_Error
1225            (Expr, "value not in range of}?", CE_Range_Check_Failed,
1226             Ent => Target_Typ,
1227             Typ => Target_Typ);
1228       end Bad_Value;
1229
1230    begin
1231       if Inside_A_Generic then
1232          return;
1233
1234       --  Return if check obviously not needed. Note that we do not check
1235       --  for the expander being inactive, since this routine does not
1236       --  insert any code, but it does generate useful warnings sometimes,
1237       --  which we would like even if we are in semantics only mode.
1238
1239       elsif Target_Typ = Any_Type
1240         or else not Is_Scalar_Type (Target_Typ)
1241         or else Raises_Constraint_Error (Expr)
1242       then
1243          return;
1244       end if;
1245
1246       --  Now, see if checks are suppressed
1247
1248       Is_Subscr_Ref :=
1249         Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component;
1250
1251       if Is_Subscr_Ref then
1252          Arr := Prefix (Parnt);
1253          Arr_Typ := Get_Actual_Subtype_If_Available (Arr);
1254       end if;
1255
1256       if not Do_Range_Check (Expr) then
1257
1258          --  Subscript reference. Check for Index_Checks suppressed
1259
1260          if Is_Subscr_Ref then
1261
1262             --  Check array type and its base type
1263
1264             if Index_Checks_Suppressed (Arr_Typ)
1265               or else Suppress_Index_Checks (Base_Type (Arr_Typ))
1266             then
1267                return;
1268
1269             --  Check array itself if it is an entity name
1270
1271             elsif Is_Entity_Name (Arr)
1272               and then Suppress_Index_Checks (Entity (Arr))
1273             then
1274                return;
1275
1276             --  Check expression itself if it is an entity name
1277
1278             elsif Is_Entity_Name (Expr)
1279               and then Suppress_Index_Checks (Entity (Expr))
1280             then
1281                return;
1282             end if;
1283
1284          --  All other cases, check for Range_Checks suppressed
1285
1286          else
1287             --  Check target type and its base type
1288
1289             if Range_Checks_Suppressed (Target_Typ)
1290               or else Suppress_Range_Checks (Base_Type (Target_Typ))
1291             then
1292                return;
1293
1294             --  Check expression itself if it is an entity name
1295
1296             elsif Is_Entity_Name (Expr)
1297               and then Suppress_Range_Checks (Entity (Expr))
1298             then
1299                return;
1300
1301             --  If Expr is part of an assignment statement, then check
1302             --  left side of assignment if it is an entity name.
1303
1304             elsif Nkind (Parnt) = N_Assignment_Statement
1305               and then Is_Entity_Name (Name (Parnt))
1306               and then Suppress_Range_Checks (Entity (Name (Parnt)))
1307             then
1308                return;
1309             end if;
1310          end if;
1311       end if;
1312
1313       --  Now see if we need a check
1314
1315       if No (Source_Typ) then
1316          S_Typ := Etype (Expr);
1317       else
1318          S_Typ := Source_Typ;
1319       end if;
1320
1321       if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then
1322          return;
1323       end if;
1324
1325       Is_Unconstrained_Subscr_Ref :=
1326         Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
1327
1328       --  Always do a range check if the source type includes infinities
1329       --  and the target type does not include infinities.
1330
1331       if Is_Floating_Point_Type (S_Typ)
1332         and then Has_Infinities (S_Typ)
1333         and then not Has_Infinities (Target_Typ)
1334       then
1335          Enable_Range_Check (Expr);
1336       end if;
1337
1338       --  Return if we know expression is definitely in the range of
1339       --  the target type as determined by Determine_Range. Right now
1340       --  we only do this for discrete types, and not fixed-point or
1341       --  floating-point types.
1342
1343       --  The additional less-precise tests below catch these cases.
1344
1345       --  Note: skip this if we are given a source_typ, since the point
1346       --  of supplying a Source_Typ is to stop us looking at the expression.
1347       --  could sharpen this test to be out parameters only ???
1348
1349       if Is_Discrete_Type (Target_Typ)
1350         and then Is_Discrete_Type (Etype (Expr))
1351         and then not Is_Unconstrained_Subscr_Ref
1352         and then No (Source_Typ)
1353       then
1354          declare
1355             Tlo : constant Node_Id := Type_Low_Bound  (Target_Typ);
1356             Thi : constant Node_Id := Type_High_Bound (Target_Typ);
1357             Lo  : Uint;
1358             Hi  : Uint;
1359
1360          begin
1361             if Compile_Time_Known_Value (Tlo)
1362               and then Compile_Time_Known_Value (Thi)
1363             then
1364                Determine_Range (Expr, OK, Lo, Hi);
1365
1366                if OK then
1367                   declare
1368                      Lov : constant Uint := Expr_Value (Tlo);
1369                      Hiv : constant Uint := Expr_Value (Thi);
1370
1371                   begin
1372                      if Lo >= Lov and then Hi <= Hiv then
1373                         return;
1374
1375                      elsif Lov > Hi or else Hiv < Lo then
1376                         Bad_Value;
1377                         return;
1378                      end if;
1379                   end;
1380                end if;
1381             end if;
1382          end;
1383       end if;
1384
1385       Int_Real :=
1386         Is_Floating_Point_Type (S_Typ)
1387           or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int);
1388
1389       --  Check if we can determine at compile time whether Expr is in the
1390       --  range of the target type. Note that if S_Typ is within the
1391       --  bounds of Target_Typ then this must be the case. This checks is
1392       --  only meaningful if this is not a conversion between integer and
1393       --  real types.
1394
1395       if not Is_Unconstrained_Subscr_Ref
1396         and then
1397            Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
1398         and then
1399           (In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int)
1400              or else
1401            Is_In_Range (Expr, Target_Typ, Fixed_Int, Int_Real))
1402       then
1403          return;
1404
1405       elsif Is_Out_Of_Range (Expr, Target_Typ, Fixed_Int, Int_Real) then
1406          Bad_Value;
1407          return;
1408
1409       --  Do not set range checks if they are killed
1410
1411       elsif Nkind (Expr) = N_Unchecked_Type_Conversion
1412         and then Kill_Range_Check (Expr)
1413       then
1414          return;
1415
1416       --  ??? We only need a runtime check if the target type is constrained
1417       --  (the predefined type Float is not for instance).
1418       --  so the following should really be
1419       --
1420       --    elsif Is_Constrained (Target_Typ) then
1421       --
1422       --  but it isn't because certain types do not have the Is_Constrained
1423       --  flag properly set (see 1503-003).
1424
1425       else
1426          Enable_Range_Check (Expr);
1427          return;
1428       end if;
1429
1430    end Apply_Scalar_Range_Check;
1431
1432    ----------------------------------
1433    -- Apply_Selected_Length_Checks --
1434    ----------------------------------
1435
1436    procedure Apply_Selected_Length_Checks
1437      (Ck_Node    : Node_Id;
1438       Target_Typ : Entity_Id;
1439       Source_Typ : Entity_Id;
1440       Do_Static  : Boolean)
1441    is
1442       Cond     : Node_Id;
1443       R_Result : Check_Result;
1444       R_Cno    : Node_Id;
1445
1446       Loc         : constant Source_Ptr := Sloc (Ck_Node);
1447       Checks_On   : constant Boolean :=
1448                       (not Index_Checks_Suppressed (Target_Typ))
1449                         or else
1450                       (not Length_Checks_Suppressed (Target_Typ));
1451
1452    begin
1453       if not Expander_Active then
1454          return;
1455       end if;
1456
1457       R_Result :=
1458         Selected_Length_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
1459
1460       for J in 1 .. 2 loop
1461
1462          R_Cno := R_Result (J);
1463          exit when No (R_Cno);
1464
1465          --  A length check may mention an Itype which is attached to a
1466          --  subsequent node. At the top level in a package this can cause
1467          --  an order-of-elaboration problem, so we make sure that the itype
1468          --  is referenced now.
1469
1470          if Ekind (Current_Scope) = E_Package
1471            and then Is_Compilation_Unit (Current_Scope)
1472          then
1473             Ensure_Defined (Target_Typ, Ck_Node);
1474
1475             if Present (Source_Typ) then
1476                Ensure_Defined (Source_Typ, Ck_Node);
1477
1478             elsif Is_Itype (Etype (Ck_Node)) then
1479                Ensure_Defined (Etype (Ck_Node), Ck_Node);
1480             end if;
1481          end if;
1482
1483          --  If the item is a conditional raise of constraint error,
1484          --  then have a look at what check is being performed and
1485          --  ???
1486
1487          if Nkind (R_Cno) = N_Raise_Constraint_Error
1488            and then Present (Condition (R_Cno))
1489          then
1490             Cond := Condition (R_Cno);
1491
1492             if not Has_Dynamic_Length_Check (Ck_Node)
1493               and then Checks_On
1494             then
1495                Insert_Action (Ck_Node, R_Cno);
1496
1497                if not Do_Static then
1498                   Set_Has_Dynamic_Length_Check (Ck_Node);
1499                end if;
1500             end if;
1501
1502             --  Output a warning if the condition is known to be True
1503
1504             if Is_Entity_Name (Cond)
1505               and then Entity (Cond) = Standard_True
1506             then
1507                Apply_Compile_Time_Constraint_Error
1508                  (Ck_Node, "wrong length for array of}?",
1509                   CE_Length_Check_Failed,
1510                   Ent => Target_Typ,
1511                   Typ => Target_Typ);
1512
1513             --  If we were only doing a static check, or if checks are not
1514             --  on, then we want to delete the check, since it is not needed.
1515             --  We do this by replacing the if statement by a null statement
1516
1517             elsif Do_Static or else not Checks_On then
1518                Rewrite (R_Cno, Make_Null_Statement (Loc));
1519             end if;
1520
1521          else
1522             Install_Static_Check (R_Cno, Loc);
1523          end if;
1524
1525       end loop;
1526
1527    end Apply_Selected_Length_Checks;
1528
1529    ---------------------------------
1530    -- Apply_Selected_Range_Checks --
1531    ---------------------------------
1532
1533    procedure Apply_Selected_Range_Checks
1534      (Ck_Node    : Node_Id;
1535       Target_Typ : Entity_Id;
1536       Source_Typ : Entity_Id;
1537       Do_Static  : Boolean)
1538    is
1539       Cond     : Node_Id;
1540       R_Result : Check_Result;
1541       R_Cno    : Node_Id;
1542
1543       Loc       : constant Source_Ptr := Sloc (Ck_Node);
1544       Checks_On : constant Boolean :=
1545                     (not Index_Checks_Suppressed (Target_Typ))
1546                       or else
1547                     (not Range_Checks_Suppressed (Target_Typ));
1548
1549    begin
1550       if not Expander_Active or else not Checks_On then
1551          return;
1552       end if;
1553
1554       R_Result :=
1555         Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
1556
1557       for J in 1 .. 2 loop
1558
1559          R_Cno := R_Result (J);
1560          exit when No (R_Cno);
1561
1562          --  If the item is a conditional raise of constraint error,
1563          --  then have a look at what check is being performed and
1564          --  ???
1565
1566          if Nkind (R_Cno) = N_Raise_Constraint_Error
1567            and then Present (Condition (R_Cno))
1568          then
1569             Cond := Condition (R_Cno);
1570
1571             if not Has_Dynamic_Range_Check (Ck_Node) then
1572                Insert_Action (Ck_Node, R_Cno);
1573
1574                if not Do_Static then
1575                   Set_Has_Dynamic_Range_Check (Ck_Node);
1576                end if;
1577             end if;
1578
1579             --  Output a warning if the condition is known to be True
1580
1581             if Is_Entity_Name (Cond)
1582               and then Entity (Cond) = Standard_True
1583             then
1584                --  Since an N_Range is technically not an expression, we
1585                --  have to set one of the bounds to C_E and then just flag
1586                --  the N_Range. The warning message will point to the
1587                --  lower bound and complain about a range, which seems OK.
1588
1589                if Nkind (Ck_Node) = N_Range then
1590                   Apply_Compile_Time_Constraint_Error
1591                     (Low_Bound (Ck_Node), "static range out of bounds of}?",
1592                      CE_Range_Check_Failed,
1593                      Ent => Target_Typ,
1594                      Typ => Target_Typ);
1595
1596                   Set_Raises_Constraint_Error (Ck_Node);
1597
1598                else
1599                   Apply_Compile_Time_Constraint_Error
1600                     (Ck_Node, "static value out of range of}?",
1601                      CE_Range_Check_Failed,
1602                      Ent => Target_Typ,
1603                      Typ => Target_Typ);
1604                end if;
1605
1606             --  If we were only doing a static check, or if checks are not
1607             --  on, then we want to delete the check, since it is not needed.
1608             --  We do this by replacing the if statement by a null statement
1609
1610             elsif Do_Static or else not Checks_On then
1611                Rewrite (R_Cno, Make_Null_Statement (Loc));
1612             end if;
1613
1614          else
1615             Install_Static_Check (R_Cno, Loc);
1616          end if;
1617
1618       end loop;
1619
1620    end Apply_Selected_Range_Checks;
1621
1622    -------------------------------
1623    -- Apply_Static_Length_Check --
1624    -------------------------------
1625
1626    procedure Apply_Static_Length_Check
1627      (Expr       : Node_Id;
1628       Target_Typ : Entity_Id;
1629       Source_Typ : Entity_Id := Empty)
1630    is
1631    begin
1632       Apply_Selected_Length_Checks
1633         (Expr, Target_Typ, Source_Typ, Do_Static => True);
1634    end Apply_Static_Length_Check;
1635
1636    -------------------------------------
1637    -- Apply_Subscript_Validity_Checks --
1638    -------------------------------------
1639
1640    procedure Apply_Subscript_Validity_Checks (Expr : Node_Id) is
1641       Sub : Node_Id;
1642
1643    begin
1644       pragma Assert (Nkind (Expr) = N_Indexed_Component);
1645
1646       --  Loop through subscripts
1647
1648       Sub := First (Expressions (Expr));
1649       while Present (Sub) loop
1650
1651          --  Check one subscript. Note that we do not worry about
1652          --  enumeration type with holes, since we will convert the
1653          --  value to a Pos value for the subscript, and that convert
1654          --  will do the necessary validity check.
1655
1656          Ensure_Valid (Sub, Holes_OK => True);
1657
1658          --  Move to next subscript
1659
1660          Sub := Next (Sub);
1661       end loop;
1662    end Apply_Subscript_Validity_Checks;
1663
1664    ----------------------------------
1665    -- Apply_Type_Conversion_Checks --
1666    ----------------------------------
1667
1668    procedure Apply_Type_Conversion_Checks (N : Node_Id) is
1669       Target_Type : constant Entity_Id := Etype (N);
1670       Target_Base : constant Entity_Id := Base_Type (Target_Type);
1671
1672       Expr      : constant Node_Id   := Expression (N);
1673       Expr_Type : constant Entity_Id := Etype (Expr);
1674
1675    begin
1676       if Inside_A_Generic then
1677          return;
1678
1679       --  Skip these checks if serious errors detected, there are some nasty
1680       --  situations of incomplete trees that blow things up.
1681
1682       elsif Serious_Errors_Detected > 0 then
1683          return;
1684
1685       --  Scalar type conversions of the form Target_Type (Expr) require
1686       --  two checks:
1687       --
1688       --    - First there is an overflow check to insure that Expr is
1689       --      in the base type of Target_Typ (4.6 (28)),
1690       --
1691       --    - After we know Expr fits into the base type, we must perform a
1692       --      range check to ensure that Expr meets the constraints of the
1693       --      Target_Type.
1694
1695       elsif Is_Scalar_Type (Target_Type) then
1696          declare
1697             Conv_OK  : constant Boolean := Conversion_OK (N);
1698             --  If the Conversion_OK flag on the type conversion is set
1699             --  and no floating point type is involved in the type conversion
1700             --  then fixed point values must be read as integral values.
1701
1702          begin
1703             --  Overflow check.
1704
1705             if not Overflow_Checks_Suppressed (Target_Base)
1706               and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK)
1707             then
1708                Set_Do_Overflow_Check (N);
1709             end if;
1710
1711             if not Range_Checks_Suppressed (Target_Type)
1712               and then not Range_Checks_Suppressed (Expr_Type)
1713             then
1714                Apply_Scalar_Range_Check
1715                  (Expr, Target_Type, Fixed_Int => Conv_OK);
1716             end if;
1717          end;
1718
1719       elsif Comes_From_Source (N)
1720         and then Is_Record_Type (Target_Type)
1721         and then Is_Derived_Type (Target_Type)
1722         and then not Is_Tagged_Type (Target_Type)
1723         and then not Is_Constrained (Target_Type)
1724         and then Present (Girder_Constraint (Target_Type))
1725       then
1726          --  A unconstrained derived type may have inherited discriminants.
1727          --  Build an actual discriminant constraint list using the girder
1728          --  constraint, to verify that the expression of the parent type
1729          --  satisfies the constraints imposed by the (unconstrained!)
1730          --  derived type. This applies to value conversions, not to view
1731          --  conversions of tagged types.
1732
1733          declare
1734             Loc             : constant Source_Ptr := Sloc (N);
1735             Cond            : Node_Id;
1736             Constraint      : Elmt_Id;
1737             Discr_Value     : Node_Id;
1738             Discr           : Entity_Id;
1739             New_Constraints : Elist_Id := New_Elmt_List;
1740             Old_Constraints : Elist_Id := Discriminant_Constraint (Expr_Type);
1741
1742          begin
1743             Constraint := First_Elmt (Girder_Constraint (Target_Type));
1744
1745             while Present (Constraint) loop
1746                Discr_Value := Node (Constraint);
1747
1748                if Is_Entity_Name (Discr_Value)
1749                  and then Ekind (Entity (Discr_Value)) = E_Discriminant
1750                then
1751                   Discr := Corresponding_Discriminant (Entity (Discr_Value));
1752
1753                   if Present (Discr)
1754                     and then Scope (Discr) = Base_Type (Expr_Type)
1755                   then
1756                      --  Parent is constrained by new discriminant. Obtain
1757                      --  Value of original discriminant in expression. If
1758                      --  the new discriminant has been used to constrain more
1759                      --  than one of the girder ones, this will provide the
1760                      --  required consistency check.
1761
1762                      Append_Elmt (
1763                         Make_Selected_Component (Loc,
1764                           Prefix =>
1765                             Duplicate_Subexpr (Expr, Name_Req => True),
1766                           Selector_Name =>
1767                             Make_Identifier (Loc, Chars (Discr))),
1768                                 New_Constraints);
1769
1770                   else
1771                      --  Discriminant of more remote ancestor ???
1772
1773                      return;
1774                   end if;
1775
1776                --  Derived type definition has an explicit value for
1777                --  this girder discriminant.
1778
1779                else
1780                   Append_Elmt
1781                     (Duplicate_Subexpr (Discr_Value), New_Constraints);
1782                end if;
1783
1784                Next_Elmt (Constraint);
1785             end loop;
1786
1787             --  Use the unconstrained expression type to retrieve the
1788             --  discriminants of the parent, and apply momentarily the
1789             --  discriminant constraint synthesized above.
1790
1791             Set_Discriminant_Constraint (Expr_Type, New_Constraints);
1792             Cond := Build_Discriminant_Checks (Expr, Expr_Type);
1793             Set_Discriminant_Constraint (Expr_Type, Old_Constraints);
1794
1795             Insert_Action (N,
1796               Make_Raise_Constraint_Error (Loc,
1797                 Condition => Cond,
1798                 Reason    => CE_Discriminant_Check_Failed));
1799          end;
1800
1801       --  should there be other checks here for array types ???
1802
1803       else
1804          null;
1805       end if;
1806
1807    end Apply_Type_Conversion_Checks;
1808
1809    ----------------------------------------------
1810    -- Apply_Universal_Integer_Attribute_Checks --
1811    ----------------------------------------------
1812
1813    procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is
1814       Loc : constant Source_Ptr := Sloc (N);
1815       Typ : constant Entity_Id  := Etype (N);
1816
1817    begin
1818       if Inside_A_Generic then
1819          return;
1820
1821       --  Nothing to do if checks are suppressed
1822
1823       elsif Range_Checks_Suppressed (Typ)
1824         and then Overflow_Checks_Suppressed (Typ)
1825       then
1826          return;
1827
1828       --  Nothing to do if the attribute does not come from source. The
1829       --  internal attributes we generate of this type do not need checks,
1830       --  and furthermore the attempt to check them causes some circular
1831       --  elaboration orders when dealing with packed types.
1832
1833       elsif not Comes_From_Source (N) then
1834          return;
1835
1836       --  Otherwise, replace the attribute node with a type conversion
1837       --  node whose expression is the attribute, retyped to universal
1838       --  integer, and whose subtype mark is the target type. The call
1839       --  to analyze this conversion will set range and overflow checks
1840       --  as required for proper detection of an out of range value.
1841
1842       else
1843          Set_Etype    (N, Universal_Integer);
1844          Set_Analyzed (N, True);
1845
1846          Rewrite (N,
1847            Make_Type_Conversion (Loc,
1848              Subtype_Mark => New_Occurrence_Of (Typ, Loc),
1849              Expression   => Relocate_Node (N)));
1850
1851          Analyze_And_Resolve (N, Typ);
1852          return;
1853       end if;
1854
1855    end Apply_Universal_Integer_Attribute_Checks;
1856
1857    -------------------------------
1858    -- Build_Discriminant_Checks --
1859    -------------------------------
1860
1861    function Build_Discriminant_Checks
1862      (N     : Node_Id;
1863       T_Typ : Entity_Id)
1864       return Node_Id
1865    is
1866       Loc      : constant Source_Ptr := Sloc (N);
1867       Cond     : Node_Id;
1868       Disc     : Elmt_Id;
1869       Disc_Ent : Entity_Id;
1870       Dval     : Node_Id;
1871
1872    begin
1873       Cond := Empty;
1874       Disc := First_Elmt (Discriminant_Constraint (T_Typ));
1875
1876       --  For a fully private type, use the discriminants of the parent
1877       --  type.
1878
1879       if Is_Private_Type (T_Typ)
1880         and then No (Full_View (T_Typ))
1881       then
1882          Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ)));
1883       else
1884          Disc_Ent := First_Discriminant (T_Typ);
1885       end if;
1886
1887       while Present (Disc) loop
1888
1889          Dval := Node (Disc);
1890
1891          if Nkind (Dval) = N_Identifier
1892            and then Ekind (Entity (Dval)) = E_Discriminant
1893          then
1894             Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc);
1895          else
1896             Dval := Duplicate_Subexpr (Dval);
1897          end if;
1898
1899          Evolve_Or_Else (Cond,
1900            Make_Op_Ne (Loc,
1901              Left_Opnd =>
1902                Make_Selected_Component (Loc,
1903                  Prefix =>
1904                    Duplicate_Subexpr (N, Name_Req => True),
1905                  Selector_Name =>
1906                    Make_Identifier (Loc, Chars (Disc_Ent))),
1907              Right_Opnd => Dval));
1908
1909          Next_Elmt (Disc);
1910          Next_Discriminant (Disc_Ent);
1911       end loop;
1912
1913       return Cond;
1914    end Build_Discriminant_Checks;
1915
1916    -----------------------------------
1917    -- Check_Valid_Lvalue_Subscripts --
1918    -----------------------------------
1919
1920    procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is
1921    begin
1922       --  Skip this if range checks are suppressed
1923
1924       if Range_Checks_Suppressed (Etype (Expr)) then
1925          return;
1926
1927       --  Only do this check for expressions that come from source. We
1928       --  assume that expander generated assignments explicitly include
1929       --  any necessary checks. Note that this is not just an optimization,
1930       --  it avoids infinite recursions!
1931
1932       elsif not Comes_From_Source (Expr) then
1933          return;
1934
1935       --  For a selected component, check the prefix
1936
1937       elsif Nkind (Expr) = N_Selected_Component then
1938          Check_Valid_Lvalue_Subscripts (Prefix (Expr));
1939          return;
1940
1941       --  Case of indexed component
1942
1943       elsif Nkind (Expr) = N_Indexed_Component then
1944          Apply_Subscript_Validity_Checks (Expr);
1945
1946          --  Prefix may itself be or contain an indexed component, and
1947          --  these subscripts need checking as well
1948
1949          Check_Valid_Lvalue_Subscripts (Prefix (Expr));
1950       end if;
1951    end Check_Valid_Lvalue_Subscripts;
1952
1953    ---------------------
1954    -- Determine_Range --
1955    ---------------------
1956
1957    Cache_Size : constant := 2 ** 10;
1958    type Cache_Index is range 0 .. Cache_Size - 1;
1959    --  Determine size of below cache (power of 2 is more efficient!)
1960
1961    Determine_Range_Cache_N  : array (Cache_Index) of Node_Id;
1962    Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
1963    Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
1964    --  The above arrays are used to implement a small direct cache
1965    --  for Determine_Range calls. Because of the way Determine_Range
1966    --  recursively traces subexpressions, and because overflow checking
1967    --  calls the routine on the way up the tree, a quadratic behavior
1968    --  can otherwise be encountered in large expressions. The cache
1969    --  entry for node N is stored in the (N mod Cache_Size) entry, and
1970    --  can be validated by checking the actual node value stored there.
1971
1972    procedure Determine_Range
1973      (N  : Node_Id;
1974       OK : out Boolean;
1975       Lo : out Uint;
1976       Hi : out Uint)
1977    is
1978       Typ : constant Entity_Id := Etype (N);
1979
1980       Lo_Left : Uint;
1981       Hi_Left : Uint;
1982       --  Lo and Hi bounds of left operand
1983
1984       Lo_Right : Uint;
1985       Hi_Right : Uint;
1986       --  Lo and Hi bounds of right (or only) operand
1987
1988       Bound : Node_Id;
1989       --  Temp variable used to hold a bound node
1990
1991       Hbound : Uint;
1992       --  High bound of base type of expression
1993
1994       Lor : Uint;
1995       Hir : Uint;
1996       --  Refined values for low and high bounds, after tightening
1997
1998       OK1 : Boolean;
1999       --  Used in lower level calls to indicate if call succeeded
2000
2001       Cindex : Cache_Index;
2002       --  Used to search cache
2003
2004       function OK_Operands return Boolean;
2005       --  Used for binary operators. Determines the ranges of the left and
2006       --  right operands, and if they are both OK, returns True, and puts
2007       --  the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left
2008
2009       -----------------
2010       -- OK_Operands --
2011       -----------------
2012
2013       function OK_Operands return Boolean is
2014       begin
2015          Determine_Range (Left_Opnd  (N), OK1, Lo_Left,  Hi_Left);
2016
2017          if not OK1 then
2018             return False;
2019          end if;
2020
2021          Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
2022          return OK1;
2023       end OK_Operands;
2024
2025    --  Start of processing for Determine_Range
2026
2027    begin
2028       --  Prevent junk warnings by initializing range variables
2029
2030       Lo  := No_Uint;
2031       Hi  := No_Uint;
2032       Lor := No_Uint;
2033       Hir := No_Uint;
2034
2035       --  If the type is not discrete, or is undefined, then we can't
2036       --  do anything about determining the range.
2037
2038       if No (Typ) or else not Is_Discrete_Type (Typ)
2039         or else Error_Posted (N)
2040       then
2041          OK := False;
2042          return;
2043       end if;
2044
2045       --  For all other cases, we can determine the range
2046
2047       OK := True;
2048
2049       --  If value is compile time known, then the possible range is the
2050       --  one value that we know this expression definitely has!
2051
2052       if Compile_Time_Known_Value (N) then
2053          Lo := Expr_Value (N);
2054          Hi := Lo;
2055          return;
2056       end if;
2057
2058       --  Return if already in the cache
2059
2060       Cindex := Cache_Index (N mod Cache_Size);
2061
2062       if Determine_Range_Cache_N (Cindex) = N then
2063          Lo := Determine_Range_Cache_Lo (Cindex);
2064          Hi := Determine_Range_Cache_Hi (Cindex);
2065          return;
2066       end if;
2067
2068       --  Otherwise, start by finding the bounds of the type of the
2069       --  expression, the value cannot be outside this range (if it
2070       --  is, then we have an overflow situation, which is a separate
2071       --  check, we are talking here only about the expression value).
2072
2073       --  We use the actual bound unless it is dynamic, in which case
2074       --  use the corresponding base type bound if possible. If we can't
2075       --  get a bound then we figure we can't determine the range (a
2076       --  peculiar case, that perhaps cannot happen, but there is no
2077       --  point in bombing in this optimization circuit.
2078
2079       --  First the low bound
2080
2081       Bound := Type_Low_Bound (Typ);
2082
2083       if Compile_Time_Known_Value (Bound) then
2084          Lo := Expr_Value (Bound);
2085
2086       elsif Compile_Time_Known_Value (Type_Low_Bound (Base_Type (Typ))) then
2087          Lo := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
2088
2089       else
2090          OK := False;
2091          return;
2092       end if;
2093
2094       --  Now the high bound
2095
2096       Bound := Type_High_Bound (Typ);
2097
2098       --  We need the high bound of the base type later on, and this should
2099       --  always be compile time known. Again, it is not clear that this
2100       --  can ever be false, but no point in bombing.
2101
2102       if Compile_Time_Known_Value (Type_High_Bound (Base_Type (Typ))) then
2103          Hbound := Expr_Value (Type_High_Bound (Base_Type (Typ)));
2104          Hi := Hbound;
2105
2106       else
2107          OK := False;
2108          return;
2109       end if;
2110
2111       --  If we have a static subtype, then that may have a tighter bound
2112       --  so use the upper bound of the subtype instead in this case.
2113
2114       if Compile_Time_Known_Value (Bound) then
2115          Hi := Expr_Value (Bound);
2116       end if;
2117
2118       --  We may be able to refine this value in certain situations. If
2119       --  refinement is possible, then Lor and Hir are set to possibly
2120       --  tighter bounds, and OK1 is set to True.
2121
2122       case Nkind (N) is
2123
2124          --  For unary plus, result is limited by range of operand
2125
2126          when N_Op_Plus =>
2127             Determine_Range (Right_Opnd (N), OK1, Lor, Hir);
2128
2129          --  For unary minus, determine range of operand, and negate it
2130
2131          when N_Op_Minus =>
2132             Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
2133
2134             if OK1 then
2135                Lor := -Hi_Right;
2136                Hir := -Lo_Right;
2137             end if;
2138
2139          --  For binary addition, get range of each operand and do the
2140          --  addition to get the result range.
2141
2142          when N_Op_Add =>
2143             if OK_Operands then
2144                Lor := Lo_Left + Lo_Right;
2145                Hir := Hi_Left + Hi_Right;
2146             end if;
2147
2148          --  Division is tricky. The only case we consider is where the
2149          --  right operand is a positive constant, and in this case we
2150          --  simply divide the bounds of the left operand
2151
2152          when N_Op_Divide =>
2153             if OK_Operands then
2154                if Lo_Right = Hi_Right
2155                  and then Lo_Right > 0
2156                then
2157                   Lor := Lo_Left / Lo_Right;
2158                   Hir := Hi_Left / Lo_Right;
2159
2160                else
2161                   OK1 := False;
2162                end if;
2163             end if;
2164
2165          --  For binary subtraction, get range of each operand and do
2166          --  the worst case subtraction to get the result range.
2167
2168          when N_Op_Subtract =>
2169             if OK_Operands then
2170                Lor := Lo_Left - Hi_Right;
2171                Hir := Hi_Left - Lo_Right;
2172             end if;
2173
2174          --  For MOD, if right operand is a positive constant, then
2175          --  result must be in the allowable range of mod results.
2176
2177          when N_Op_Mod =>
2178             if OK_Operands then
2179                if Lo_Right = Hi_Right then
2180                   if Lo_Right > 0 then
2181                      Lor := Uint_0;
2182                      Hir := Lo_Right - 1;
2183
2184                   elsif Lo_Right < 0 then
2185                      Lor := Lo_Right + 1;
2186                      Hir := Uint_0;
2187                   end if;
2188
2189                else
2190                   OK1 := False;
2191                end if;
2192             end if;
2193
2194          --  For REM, if right operand is a positive constant, then
2195          --  result must be in the allowable range of mod results.
2196
2197          when N_Op_Rem =>
2198             if OK_Operands then
2199                if Lo_Right = Hi_Right then
2200                   declare
2201                      Dval : constant Uint := (abs Lo_Right) - 1;
2202
2203                   begin
2204                      --  The sign of the result depends on the sign of the
2205                      --  dividend (but not on the sign of the divisor, hence
2206                      --  the abs operation above).
2207
2208                      if Lo_Left < 0 then
2209                         Lor := -Dval;
2210                      else
2211                         Lor := Uint_0;
2212                      end if;
2213
2214                      if Hi_Left < 0 then
2215                         Hir := Uint_0;
2216                      else
2217                         Hir := Dval;
2218                      end if;
2219                   end;
2220
2221                else
2222                   OK1 := False;
2223                end if;
2224             end if;
2225
2226          --  Attribute reference cases
2227
2228          when N_Attribute_Reference =>
2229             case Attribute_Name (N) is
2230
2231                --  For Pos/Val attributes, we can refine the range using the
2232                --  possible range of values of the attribute expression
2233
2234                when Name_Pos | Name_Val =>
2235                   Determine_Range (First (Expressions (N)), OK1, Lor, Hir);
2236
2237                --  For Length attribute, use the bounds of the corresponding
2238                --  index type to refine the range.
2239
2240                when Name_Length =>
2241                   declare
2242                      Atyp : Entity_Id := Etype (Prefix (N));
2243                      Inum : Nat;
2244                      Indx : Node_Id;
2245
2246                      LL, LU : Uint;
2247                      UL, UU : Uint;
2248
2249                   begin
2250                      if Is_Access_Type (Atyp) then
2251                         Atyp := Designated_Type (Atyp);
2252                      end if;
2253
2254                      --  For string literal, we know exact value
2255
2256                      if Ekind (Atyp) = E_String_Literal_Subtype then
2257                         OK := True;
2258                         Lo := String_Literal_Length (Atyp);
2259                         Hi := String_Literal_Length (Atyp);
2260                         return;
2261                      end if;
2262
2263                      --  Otherwise check for expression given
2264
2265                      if No (Expressions (N)) then
2266                         Inum := 1;
2267                      else
2268                         Inum :=
2269                           UI_To_Int (Expr_Value (First (Expressions (N))));
2270                      end if;
2271
2272                      Indx := First_Index (Atyp);
2273                      for J in 2 .. Inum loop
2274                         Indx := Next_Index (Indx);
2275                      end loop;
2276
2277                      Determine_Range
2278                        (Type_Low_Bound (Etype (Indx)), OK1, LL, LU);
2279
2280                      if OK1 then
2281                         Determine_Range
2282                           (Type_High_Bound (Etype (Indx)), OK1, UL, UU);
2283
2284                         if OK1 then
2285
2286                            --  The maximum value for Length is the biggest
2287                            --  possible gap between the values of the bounds.
2288                            --  But of course, this value cannot be negative.
2289
2290                            Hir := UI_Max (Uint_0, UU - LL);
2291
2292                            --  For constrained arrays, the minimum value for
2293                            --  Length is taken from the actual value of the
2294                            --  bounds, since the index will be exactly of
2295                            --  this subtype.
2296
2297                            if Is_Constrained (Atyp) then
2298                               Lor := UI_Max (Uint_0, UL - LU);
2299
2300                            --  For an unconstrained array, the minimum value
2301                            --  for length is always zero.
2302
2303                            else
2304                               Lor := Uint_0;
2305                            end if;
2306                         end if;
2307                      end if;
2308                   end;
2309
2310                --  No special handling for other attributes
2311                --  Probably more opportunities exist here ???
2312
2313                when others =>
2314                   OK1 := False;
2315
2316             end case;
2317
2318          --  For type conversion from one discrete type to another, we
2319          --  can refine the range using the converted value.
2320
2321          when N_Type_Conversion =>
2322             Determine_Range (Expression (N), OK1, Lor, Hir);
2323
2324          --  Nothing special to do for all other expression kinds
2325
2326          when others =>
2327             OK1 := False;
2328             Lor := No_Uint;
2329             Hir := No_Uint;
2330       end case;
2331
2332       --  At this stage, if OK1 is true, then we know that the actual
2333       --  result of the computed expression is in the range Lor .. Hir.
2334       --  We can use this to restrict the possible range of results.
2335
2336       if OK1 then
2337
2338          --  If the refined value of the low bound is greater than the
2339          --  type high bound, then reset it to the more restrictive
2340          --  value. However, we do NOT do this for the case of a modular
2341          --  type where the possible upper bound on the value is above the
2342          --  base type high bound, because that means the result could wrap.
2343
2344          if Lor > Lo
2345            and then not (Is_Modular_Integer_Type (Typ)
2346                            and then Hir > Hbound)
2347          then
2348             Lo := Lor;
2349          end if;
2350
2351          --  Similarly, if the refined value of the high bound is less
2352          --  than the value so far, then reset it to the more restrictive
2353          --  value. Again, we do not do this if the refined low bound is
2354          --  negative for a modular type, since this would wrap.
2355
2356          if Hir < Hi
2357            and then not (Is_Modular_Integer_Type (Typ)
2358                           and then Lor < Uint_0)
2359          then
2360             Hi := Hir;
2361          end if;
2362       end if;
2363
2364       --  Set cache entry for future call and we are all done
2365
2366       Determine_Range_Cache_N  (Cindex) := N;
2367       Determine_Range_Cache_Lo (Cindex) := Lo;
2368       Determine_Range_Cache_Hi (Cindex) := Hi;
2369       return;
2370
2371    --  If any exception occurs, it means that we have some bug in the compiler
2372    --  possibly triggered by a previous error, or by some unforseen peculiar
2373    --  occurrence. However, this is only an optimization attempt, so there is
2374    --  really no point in crashing the compiler. Instead we just decide, too
2375    --  bad, we can't figure out a range in this case after all.
2376
2377    exception
2378       when others =>
2379
2380          --  Debug flag K disables this behavior (useful for debugging)
2381
2382          if Debug_Flag_K then
2383             raise;
2384          else
2385             OK := False;
2386             Lo := No_Uint;
2387             Hi := No_Uint;
2388             return;
2389          end if;
2390
2391    end Determine_Range;
2392
2393    ------------------------------------
2394    -- Discriminant_Checks_Suppressed --
2395    ------------------------------------
2396
2397    function Discriminant_Checks_Suppressed (E : Entity_Id) return Boolean is
2398    begin
2399       return Scope_Suppress.Discriminant_Checks
2400         or else (Present (E) and then Suppress_Discriminant_Checks (E));
2401    end Discriminant_Checks_Suppressed;
2402
2403    --------------------------------
2404    -- Division_Checks_Suppressed --
2405    --------------------------------
2406
2407    function Division_Checks_Suppressed (E : Entity_Id) return Boolean is
2408    begin
2409       return Scope_Suppress.Division_Checks
2410         or else (Present (E) and then Suppress_Division_Checks (E));
2411    end Division_Checks_Suppressed;
2412
2413    -----------------------------------
2414    -- Elaboration_Checks_Suppressed --
2415    -----------------------------------
2416
2417    function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
2418    begin
2419       return Scope_Suppress.Elaboration_Checks
2420         or else (Present (E) and then Suppress_Elaboration_Checks (E));
2421    end Elaboration_Checks_Suppressed;
2422
2423    ------------------------
2424    -- Enable_Range_Check --
2425    ------------------------
2426
2427    procedure Enable_Range_Check (N : Node_Id) is
2428    begin
2429       if Nkind (N) = N_Unchecked_Type_Conversion
2430         and then Kill_Range_Check (N)
2431       then
2432          return;
2433       else
2434          Set_Do_Range_Check (N, True);
2435       end if;
2436    end Enable_Range_Check;
2437
2438    ------------------
2439    -- Ensure_Valid --
2440    ------------------
2441
2442    procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False) is
2443       Typ : constant Entity_Id  := Etype (Expr);
2444
2445    begin
2446       --  Ignore call if we are not doing any validity checking
2447
2448       if not Validity_Checks_On then
2449          return;
2450
2451       --  No check required if expression is from the expander, we assume
2452       --  the expander will generate whatever checks are needed. Note that
2453       --  this is not just an optimization, it avoids infinite recursions!
2454
2455       --  Unchecked conversions must be checked, unless they are initialized
2456       --  scalar values, as in a component assignment in an init_proc.
2457
2458       elsif not Comes_From_Source (Expr)
2459         and then (Nkind (Expr) /= N_Unchecked_Type_Conversion
2460                     or else Kill_Range_Check (Expr))
2461       then
2462          return;
2463
2464       --  No check required if expression is known to have valid value
2465
2466       elsif Expr_Known_Valid (Expr) then
2467          return;
2468
2469       --  No check required if checks off
2470
2471       elsif Range_Checks_Suppressed (Typ) then
2472          return;
2473
2474       --  Ignore case of enumeration with holes where the flag is set not
2475       --  to worry about holes, since no special validity check is needed
2476
2477       elsif Is_Enumeration_Type (Typ)
2478         and then Has_Non_Standard_Rep (Typ)
2479         and then Holes_OK
2480       then
2481          return;
2482
2483       --  No check required on the left-hand side of an assignment.
2484
2485       elsif Nkind (Parent (Expr)) = N_Assignment_Statement
2486         and then Expr = Name (Parent (Expr))
2487       then
2488          return;
2489
2490       --  An annoying special case. If this is an out parameter of a scalar
2491       --  type, then the value is not going to be accessed, therefore it is
2492       --  inappropriate to do any validity check at the call site.
2493
2494       else
2495          --  Only need to worry about scalar types
2496
2497          if Is_Scalar_Type (Typ) then
2498             declare
2499                P : Node_Id;
2500                N : Node_Id;
2501                E : Entity_Id;
2502                F : Entity_Id;
2503                A : Node_Id;
2504                L : List_Id;
2505
2506             begin
2507                --  Find actual argument (which may be a parameter association)
2508                --  and the parent of the actual argument (the call statement)
2509
2510                N := Expr;
2511                P := Parent (Expr);
2512
2513                if Nkind (P) = N_Parameter_Association then
2514                   N := P;
2515                   P := Parent (N);
2516                end if;
2517
2518                --  Only need to worry if we are argument of a procedure
2519                --  call since functions don't have out parameters.
2520
2521                if Nkind (P) = N_Procedure_Call_Statement then
2522                   L := Parameter_Associations (P);
2523                   E := Entity (Name (P));
2524
2525                   --  Only need to worry if there are indeed actuals, and
2526                   --  if this could be a procedure call, otherwise we cannot
2527                   --  get a match (either we are not an argument, or the
2528                   --  mode of the formal is not OUT). This test also filters
2529                   --  out the generic case.
2530
2531                   if Is_Non_Empty_List (L)
2532                     and then Is_Subprogram (E)
2533                   then
2534                      --  This is the loop through parameters, looking to
2535                      --  see if there is an OUT parameter for which we are
2536                      --  the argument.
2537
2538                      F := First_Formal (E);
2539                      A := First (L);
2540
2541                      while Present (F) loop
2542                         if Ekind (F) = E_Out_Parameter and then A = N then
2543                            return;
2544                         end if;
2545
2546                         Next_Formal (F);
2547                         Next (A);
2548                      end loop;
2549                   end if;
2550                end if;
2551             end;
2552          end if;
2553       end if;
2554
2555       --  If we fall through, a validity check is required. Note that it would
2556       --  not be good to set Do_Range_Check, even in contexts where this is
2557       --  permissible, since this flag causes checking against the target type,
2558       --  not the source type in contexts such as assignments
2559
2560       Insert_Valid_Check (Expr);
2561    end Ensure_Valid;
2562
2563    ----------------------
2564    -- Expr_Known_Valid --
2565    ----------------------
2566
2567    function Expr_Known_Valid (Expr : Node_Id) return Boolean is
2568       Typ : constant Entity_Id := Etype (Expr);
2569
2570    begin
2571       --  Non-scalar types are always consdered valid, since they never
2572       --  give rise to the issues of erroneous or bounded error behavior
2573       --  that are the concern. In formal reference manual terms the
2574       --  notion of validity only applies to scalar types.
2575
2576       if not Is_Scalar_Type (Typ) then
2577          return True;
2578
2579       --  If no validity checking, then everything is considered valid
2580
2581       elsif not Validity_Checks_On then
2582          return True;
2583
2584       --  Floating-point types are considered valid unless floating-point
2585       --  validity checks have been specifically turned on.
2586
2587       elsif Is_Floating_Point_Type (Typ)
2588         and then not Validity_Check_Floating_Point
2589       then
2590          return True;
2591
2592       --  If the expression is the value of an object that is known to
2593       --  be valid, then clearly the expression value itself is valid.
2594
2595       elsif Is_Entity_Name (Expr)
2596         and then Is_Known_Valid (Entity (Expr))
2597       then
2598          return True;
2599
2600       --  If the type is one for which all values are known valid, then
2601       --  we are sure that the value is valid except in the slightly odd
2602       --  case where the expression is a reference to a variable whose size
2603       --  has been explicitly set to a value greater than the object size.
2604
2605       elsif Is_Known_Valid (Typ) then
2606          if Is_Entity_Name (Expr)
2607            and then Ekind (Entity (Expr)) = E_Variable
2608            and then Esize (Entity (Expr)) > Esize (Typ)
2609          then
2610             return False;
2611          else
2612             return True;
2613          end if;
2614
2615       --  Integer and character literals always have valid values, where
2616       --  appropriate these will be range checked in any case.
2617
2618       elsif Nkind (Expr) = N_Integer_Literal
2619               or else
2620             Nkind (Expr) = N_Character_Literal
2621       then
2622          return True;
2623
2624       --  If we have a type conversion or a qualification of a known valid
2625       --  value, then the result will always be valid.
2626
2627       elsif Nkind (Expr) = N_Type_Conversion
2628               or else
2629             Nkind (Expr) = N_Qualified_Expression
2630       then
2631          return Expr_Known_Valid (Expression (Expr));
2632
2633       --  The result of any function call or operator is always considered
2634       --  valid, since we assume the necessary checks are done by the call.
2635
2636       elsif Nkind (Expr) in N_Binary_Op
2637               or else
2638             Nkind (Expr) in N_Unary_Op
2639               or else
2640             Nkind (Expr) = N_Function_Call
2641       then
2642          return True;
2643
2644       --  For all other cases, we do not know the expression is valid
2645
2646       else
2647          return False;
2648       end if;
2649    end Expr_Known_Valid;
2650
2651    ---------------------
2652    -- Get_Discriminal --
2653    ---------------------
2654
2655    function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id is
2656       Loc : constant Source_Ptr := Sloc (E);
2657       D   : Entity_Id;
2658       Sc  : Entity_Id;
2659
2660    begin
2661       --  The entity E is the type of a private component of the protected
2662       --  type, or the type of a renaming of that component within a protected
2663       --  operation of that type.
2664
2665       Sc := Scope (E);
2666
2667       if Ekind (Sc) /= E_Protected_Type then
2668          Sc := Scope (Sc);
2669
2670          if Ekind (Sc) /= E_Protected_Type then
2671             return Bound;
2672          end if;
2673       end if;
2674
2675       D := First_Discriminant (Sc);
2676
2677       while Present (D)
2678         and then Chars (D) /= Chars (Bound)
2679       loop
2680          Next_Discriminant (D);
2681       end loop;
2682
2683       return New_Occurrence_Of (Discriminal (D), Loc);
2684    end Get_Discriminal;
2685
2686    ------------------
2687    -- Guard_Access --
2688    ------------------
2689
2690    function Guard_Access
2691      (Cond    : Node_Id;
2692       Loc     : Source_Ptr;
2693       Ck_Node : Node_Id)
2694       return    Node_Id
2695    is
2696    begin
2697       if Nkind (Cond) = N_Or_Else then
2698          Set_Paren_Count (Cond, 1);
2699       end if;
2700
2701       if Nkind (Ck_Node) = N_Allocator then
2702          return Cond;
2703       else
2704          return
2705            Make_And_Then (Loc,
2706              Left_Opnd =>
2707                Make_Op_Ne (Loc,
2708                  Left_Opnd  => Duplicate_Subexpr (Ck_Node),
2709                  Right_Opnd => Make_Null (Loc)),
2710              Right_Opnd => Cond);
2711       end if;
2712    end Guard_Access;
2713
2714    -----------------------------
2715    -- Index_Checks_Suppressed --
2716    -----------------------------
2717
2718    function Index_Checks_Suppressed (E : Entity_Id) return Boolean is
2719    begin
2720       return Scope_Suppress.Index_Checks
2721         or else (Present (E) and then Suppress_Index_Checks (E));
2722    end Index_Checks_Suppressed;
2723
2724    ----------------
2725    -- Initialize --
2726    ----------------
2727
2728    procedure Initialize is
2729    begin
2730       for J in Determine_Range_Cache_N'Range loop
2731          Determine_Range_Cache_N (J) := Empty;
2732       end loop;
2733    end Initialize;
2734
2735    -------------------------
2736    -- Insert_Range_Checks --
2737    -------------------------
2738
2739    procedure Insert_Range_Checks
2740      (Checks       : Check_Result;
2741       Node         : Node_Id;
2742       Suppress_Typ : Entity_Id;
2743       Static_Sloc  : Source_Ptr := No_Location;
2744       Flag_Node    : Node_Id    := Empty;
2745       Do_Before    : Boolean    := False)
2746    is
2747       Internal_Flag_Node   : Node_Id    := Flag_Node;
2748       Internal_Static_Sloc : Source_Ptr := Static_Sloc;
2749
2750       Check_Node : Node_Id;
2751       Checks_On  : constant Boolean :=
2752                      (not Index_Checks_Suppressed (Suppress_Typ))
2753                        or else
2754                      (not Range_Checks_Suppressed (Suppress_Typ));
2755
2756    begin
2757       --  For now we just return if Checks_On is false, however this should
2758       --  be enhanced to check for an always True value in the condition
2759       --  and to generate a compilation warning???
2760
2761       if not Expander_Active or else not Checks_On then
2762          return;
2763       end if;
2764
2765       if Static_Sloc = No_Location then
2766          Internal_Static_Sloc := Sloc (Node);
2767       end if;
2768
2769       if No (Flag_Node) then
2770          Internal_Flag_Node := Node;
2771       end if;
2772
2773       for J in 1 .. 2 loop
2774          exit when No (Checks (J));
2775
2776          if Nkind (Checks (J)) = N_Raise_Constraint_Error
2777            and then Present (Condition (Checks (J)))
2778          then
2779             if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
2780                Check_Node := Checks (J);
2781                Mark_Rewrite_Insertion (Check_Node);
2782
2783                if Do_Before then
2784                   Insert_Before_And_Analyze (Node, Check_Node);
2785                else
2786                   Insert_After_And_Analyze (Node, Check_Node);
2787                end if;
2788
2789                Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
2790             end if;
2791
2792          else
2793             Check_Node :=
2794               Make_Raise_Constraint_Error (Internal_Static_Sloc,
2795                 Reason => CE_Range_Check_Failed);
2796             Mark_Rewrite_Insertion (Check_Node);
2797
2798             if Do_Before then
2799                Insert_Before_And_Analyze (Node, Check_Node);
2800             else
2801                Insert_After_And_Analyze (Node, Check_Node);
2802             end if;
2803          end if;
2804       end loop;
2805    end Insert_Range_Checks;
2806
2807    ------------------------
2808    -- Insert_Valid_Check --
2809    ------------------------
2810
2811    procedure Insert_Valid_Check (Expr : Node_Id) is
2812       Loc : constant Source_Ptr := Sloc (Expr);
2813       Exp : Node_Id;
2814
2815    begin
2816       --  Do not insert if checks off, or if not checking validity
2817
2818       if Range_Checks_Suppressed (Etype (Expr))
2819         or else (not Validity_Checks_On)
2820       then
2821          return;
2822       end if;
2823
2824       --  If we have a checked conversion, then validity check applies to
2825       --  the expression inside the conversion, not the result, since if
2826       --  the expression inside is valid, then so is the conversion result.
2827
2828       Exp := Expr;
2829       while Nkind (Exp) = N_Type_Conversion loop
2830          Exp := Expression (Exp);
2831       end loop;
2832
2833       --  Insert the validity check. Note that we do this with validity
2834       --  checks turned off, to avoid recursion, we do not want validity
2835       --  checks on the validity checking code itself!
2836
2837       Validity_Checks_On := False;
2838       Insert_Action
2839         (Expr,
2840          Make_Raise_Constraint_Error (Loc,
2841            Condition =>
2842              Make_Op_Not (Loc,
2843                Right_Opnd =>
2844                  Make_Attribute_Reference (Loc,
2845                    Prefix =>
2846                      Duplicate_Subexpr (Exp, Name_Req => True),
2847                    Attribute_Name => Name_Valid)),
2848            Reason => CE_Invalid_Data),
2849          Suppress => All_Checks);
2850       Validity_Checks_On := True;
2851    end Insert_Valid_Check;
2852
2853    --------------------------
2854    -- Install_Static_Check --
2855    --------------------------
2856
2857    procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr) is
2858       Stat : constant Boolean   := Is_Static_Expression (R_Cno);
2859       Typ  : constant Entity_Id := Etype (R_Cno);
2860
2861    begin
2862       Rewrite (R_Cno,
2863         Make_Raise_Constraint_Error (Loc,
2864           Reason => CE_Range_Check_Failed));
2865       Set_Analyzed (R_Cno);
2866       Set_Etype (R_Cno, Typ);
2867       Set_Raises_Constraint_Error (R_Cno);
2868       Set_Is_Static_Expression (R_Cno, Stat);
2869    end Install_Static_Check;
2870
2871    ------------------------------
2872    -- Length_Checks_Suppressed --
2873    ------------------------------
2874
2875    function Length_Checks_Suppressed (E : Entity_Id) return Boolean is
2876    begin
2877       return Scope_Suppress.Length_Checks
2878         or else (Present (E) and then Suppress_Length_Checks (E));
2879    end Length_Checks_Suppressed;
2880
2881    --------------------------------
2882    -- Overflow_Checks_Suppressed --
2883    --------------------------------
2884
2885    function Overflow_Checks_Suppressed (E : Entity_Id) return Boolean is
2886    begin
2887       return Scope_Suppress.Overflow_Checks
2888         or else (Present (E) and then Suppress_Overflow_Checks (E));
2889    end Overflow_Checks_Suppressed;
2890
2891    -----------------
2892    -- Range_Check --
2893    -----------------
2894
2895    function Range_Check
2896      (Ck_Node    : Node_Id;
2897       Target_Typ : Entity_Id;
2898       Source_Typ : Entity_Id := Empty;
2899       Warn_Node  : Node_Id   := Empty)
2900       return       Check_Result
2901    is
2902    begin
2903       return Selected_Range_Checks
2904         (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
2905    end Range_Check;
2906
2907    -----------------------------
2908    -- Range_Checks_Suppressed --
2909    -----------------------------
2910
2911    function Range_Checks_Suppressed (E : Entity_Id) return Boolean is
2912    begin
2913       --  Note: for now we always suppress range checks on Vax float types,
2914       --  since Gigi does not know how to generate these checks.
2915
2916       return Scope_Suppress.Range_Checks
2917         or else (Present (E) and then Suppress_Range_Checks (E))
2918         or else Vax_Float (E);
2919    end Range_Checks_Suppressed;
2920
2921    ----------------------------
2922    -- Selected_Length_Checks --
2923    ----------------------------
2924
2925    function Selected_Length_Checks
2926      (Ck_Node    : Node_Id;
2927       Target_Typ : Entity_Id;
2928       Source_Typ : Entity_Id;
2929       Warn_Node  : Node_Id)
2930       return       Check_Result
2931    is
2932       Loc         : constant Source_Ptr := Sloc (Ck_Node);
2933       S_Typ       : Entity_Id;
2934       T_Typ       : Entity_Id;
2935       Expr_Actual : Node_Id;
2936       Exptyp      : Entity_Id;
2937       Cond        : Node_Id := Empty;
2938       Do_Access   : Boolean := False;
2939       Wnode       : Node_Id := Warn_Node;
2940       Ret_Result  : Check_Result := (Empty, Empty);
2941       Num_Checks  : Natural := 0;
2942
2943       procedure Add_Check (N : Node_Id);
2944       --  Adds the action given to Ret_Result if N is non-Empty
2945
2946       function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id;
2947       function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id;
2948
2949       function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
2950       --  True for equal literals and for nodes that denote the same constant
2951       --  entity, even if its value is not a static constant. This includes the
2952       --  case of a discriminal reference within an init_proc. Removes some
2953       --  obviously superfluous checks.
2954
2955       function Length_E_Cond
2956         (Exptyp : Entity_Id;
2957          Typ    : Entity_Id;
2958          Indx   : Nat)
2959          return   Node_Id;
2960       --  Returns expression to compute:
2961       --    Typ'Length /= Exptyp'Length
2962
2963       function Length_N_Cond
2964         (Expr : Node_Id;
2965          Typ  : Entity_Id;
2966          Indx : Nat)
2967          return Node_Id;
2968       --  Returns expression to compute:
2969       --    Typ'Length /= Expr'Length
2970
2971       ---------------
2972       -- Add_Check --
2973       ---------------
2974
2975       procedure Add_Check (N : Node_Id) is
2976       begin
2977          if Present (N) then
2978
2979             --  For now, ignore attempt to place more than 2 checks ???
2980
2981             if Num_Checks = 2 then
2982                return;
2983             end if;
2984
2985             pragma Assert (Num_Checks <= 1);
2986             Num_Checks := Num_Checks + 1;
2987             Ret_Result (Num_Checks) := N;
2988          end if;
2989       end Add_Check;
2990
2991       ------------------
2992       -- Get_E_Length --
2993       ------------------
2994
2995       function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
2996          N  : Node_Id;
2997          E1 : Entity_Id := E;
2998          Pt : Entity_Id := Scope (Scope (E));
2999
3000       begin
3001          if Ekind (Scope (E)) = E_Record_Type
3002            and then Has_Discriminants (Scope (E))
3003          then
3004             N := Build_Discriminal_Subtype_Of_Component (E);
3005
3006             if Present (N) then
3007                Insert_Action (Ck_Node, N);
3008                E1 := Defining_Identifier (N);
3009             end if;
3010          end if;
3011
3012          if Ekind (E1) = E_String_Literal_Subtype then
3013             return
3014               Make_Integer_Literal (Loc,
3015                 Intval => String_Literal_Length (E1));
3016
3017          elsif Ekind (Pt) = E_Protected_Type
3018            and then Has_Discriminants (Pt)
3019            and then Has_Completion (Pt)
3020            and then not Inside_Init_Proc
3021          then
3022
3023             --  If the type whose length is needed is a private component
3024             --  constrained by a discriminant, we must expand the 'Length
3025             --  attribute into an explicit computation, using the discriminal
3026             --  of the current protected operation. This is because the actual
3027             --  type of the prival is constructed after the protected opera-
3028             --  tion has been fully expanded.
3029
3030             declare
3031                Indx_Type : Node_Id;
3032                Lo        : Node_Id;
3033                Hi        : Node_Id;
3034                Do_Expand : Boolean := False;
3035
3036             begin
3037                Indx_Type := First_Index (E);
3038
3039                for J in 1 .. Indx - 1 loop
3040                   Next_Index (Indx_Type);
3041                end loop;
3042
3043                Get_Index_Bounds  (Indx_Type, Lo, Hi);
3044
3045                if Nkind (Lo) = N_Identifier
3046                  and then Ekind (Entity (Lo)) = E_In_Parameter
3047                then
3048                   Lo := Get_Discriminal (E, Lo);
3049                   Do_Expand := True;
3050                end if;
3051
3052                if Nkind (Hi) = N_Identifier
3053                  and then Ekind (Entity (Hi)) = E_In_Parameter
3054                then
3055                   Hi := Get_Discriminal (E, Hi);
3056                   Do_Expand := True;
3057                end if;
3058
3059                if Do_Expand then
3060                   if not Is_Entity_Name (Lo) then
3061                      Lo := Duplicate_Subexpr (Lo);
3062                   end if;
3063
3064                   if not Is_Entity_Name (Hi) then
3065                      Lo := Duplicate_Subexpr (Hi);
3066                   end if;
3067
3068                   N :=
3069                     Make_Op_Add (Loc,
3070                       Left_Opnd =>
3071                         Make_Op_Subtract (Loc,
3072                           Left_Opnd  => Hi,
3073                           Right_Opnd => Lo),
3074
3075                       Right_Opnd => Make_Integer_Literal (Loc, 1));
3076                   return N;
3077
3078                else
3079                   N :=
3080                     Make_Attribute_Reference (Loc,
3081                       Attribute_Name => Name_Length,
3082                       Prefix =>
3083                         New_Occurrence_Of (E1, Loc));
3084
3085                   if Indx > 1 then
3086                      Set_Expressions (N, New_List (
3087                        Make_Integer_Literal (Loc, Indx)));
3088                   end if;
3089
3090                   return N;
3091                end if;
3092             end;
3093
3094          else
3095             N :=
3096               Make_Attribute_Reference (Loc,
3097                 Attribute_Name => Name_Length,
3098                 Prefix =>
3099                   New_Occurrence_Of (E1, Loc));
3100
3101             if Indx > 1 then
3102                Set_Expressions (N, New_List (
3103                  Make_Integer_Literal (Loc, Indx)));
3104             end if;
3105
3106             return N;
3107
3108          end if;
3109       end Get_E_Length;
3110
3111       ------------------
3112       -- Get_N_Length --
3113       ------------------
3114
3115       function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id is
3116       begin
3117          return
3118            Make_Attribute_Reference (Loc,
3119              Attribute_Name => Name_Length,
3120              Prefix =>
3121                Duplicate_Subexpr (N, Name_Req => True),
3122              Expressions => New_List (
3123                Make_Integer_Literal (Loc, Indx)));
3124
3125       end Get_N_Length;
3126
3127       -------------------
3128       -- Length_E_Cond --
3129       -------------------
3130
3131       function Length_E_Cond
3132         (Exptyp : Entity_Id;
3133          Typ    : Entity_Id;
3134          Indx   : Nat)
3135          return   Node_Id
3136       is
3137       begin
3138          return
3139            Make_Op_Ne (Loc,
3140              Left_Opnd  => Get_E_Length (Typ, Indx),
3141              Right_Opnd => Get_E_Length (Exptyp, Indx));
3142
3143       end Length_E_Cond;
3144
3145       -------------------
3146       -- Length_N_Cond --
3147       -------------------
3148
3149       function Length_N_Cond
3150         (Expr : Node_Id;
3151          Typ  : Entity_Id;
3152          Indx : Nat)
3153          return Node_Id
3154       is
3155       begin
3156          return
3157            Make_Op_Ne (Loc,
3158              Left_Opnd  => Get_E_Length (Typ, Indx),
3159              Right_Opnd => Get_N_Length (Expr, Indx));
3160
3161       end Length_N_Cond;
3162
3163       function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is
3164       begin
3165          return
3166            (Nkind (L) = N_Integer_Literal
3167              and then Nkind (R) = N_Integer_Literal
3168              and then Intval (L) = Intval (R))
3169
3170           or else
3171             (Is_Entity_Name (L)
3172               and then Ekind (Entity (L)) = E_Constant
3173               and then ((Is_Entity_Name (R)
3174                          and then Entity (L) = Entity (R))
3175                         or else
3176                        (Nkind (R) = N_Type_Conversion
3177                          and then Is_Entity_Name (Expression (R))
3178                          and then Entity (L) = Entity (Expression (R)))))
3179
3180           or else
3181             (Is_Entity_Name (R)
3182               and then Ekind (Entity (R)) = E_Constant
3183               and then Nkind (L) = N_Type_Conversion
3184               and then Is_Entity_Name (Expression (L))
3185               and then Entity (R) = Entity (Expression (L)))
3186
3187          or else
3188             (Is_Entity_Name (L)
3189               and then Is_Entity_Name (R)
3190               and then Entity (L) = Entity (R)
3191               and then Ekind (Entity (L)) = E_In_Parameter
3192               and then Inside_Init_Proc);
3193       end Same_Bounds;
3194
3195    --  Start of processing for Selected_Length_Checks
3196
3197    begin
3198       if not Expander_Active then
3199          return Ret_Result;
3200       end if;
3201
3202       if Target_Typ = Any_Type
3203         or else Target_Typ = Any_Composite
3204         or else Raises_Constraint_Error (Ck_Node)
3205       then
3206          return Ret_Result;
3207       end if;
3208
3209       if No (Wnode) then
3210          Wnode := Ck_Node;
3211       end if;
3212
3213       T_Typ := Target_Typ;
3214
3215       if No (Source_Typ) then
3216          S_Typ := Etype (Ck_Node);
3217       else
3218          S_Typ := Source_Typ;
3219       end if;
3220
3221       if S_Typ = Any_Type or else S_Typ = Any_Composite then
3222          return Ret_Result;
3223       end if;
3224
3225       if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
3226          S_Typ := Designated_Type (S_Typ);
3227          T_Typ := Designated_Type (T_Typ);
3228          Do_Access := True;
3229
3230          --  A simple optimization
3231
3232          if Nkind (Ck_Node) = N_Null then
3233             return Ret_Result;
3234          end if;
3235       end if;
3236
3237       if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
3238          if Is_Constrained (T_Typ) then
3239
3240             --  The checking code to be generated will freeze the
3241             --  corresponding array type. However, we must freeze the
3242             --  type now, so that the freeze node does not appear within
3243             --  the generated condional expression, but ahead of it.
3244
3245             Freeze_Before (Ck_Node, T_Typ);
3246
3247             Expr_Actual := Get_Referenced_Object (Ck_Node);
3248             Exptyp      := Get_Actual_Subtype (Expr_Actual);
3249
3250             if Is_Access_Type (Exptyp) then
3251                Exptyp := Designated_Type (Exptyp);
3252             end if;
3253
3254             --  String_Literal case. This needs to be handled specially be-
3255             --  cause no index types are available for string literals. The
3256             --  condition is simply:
3257
3258             --    T_Typ'Length = string-literal-length
3259
3260             if Nkind (Expr_Actual) = N_String_Literal then
3261                Cond :=
3262                  Make_Op_Ne (Loc,
3263                    Left_Opnd  => Get_E_Length (T_Typ, 1),
3264                    Right_Opnd =>
3265                      Make_Integer_Literal (Loc,
3266                        Intval =>
3267                          String_Literal_Length (Etype (Expr_Actual))));
3268
3269             --  General array case. Here we have a usable actual subtype for
3270             --  the expression, and the condition is built from the two types
3271             --  (Do_Length):
3272
3273             --     T_Typ'Length     /= Exptyp'Length     or else
3274             --     T_Typ'Length (2) /= Exptyp'Length (2) or else
3275             --     T_Typ'Length (3) /= Exptyp'Length (3) or else
3276             --     ...
3277
3278             elsif Is_Constrained (Exptyp) then
3279                declare
3280                   L_Index : Node_Id;
3281                   R_Index : Node_Id;
3282                   Ndims   : Nat := Number_Dimensions (T_Typ);
3283
3284                   L_Low  : Node_Id;
3285                   L_High : Node_Id;
3286                   R_Low  : Node_Id;
3287                   R_High : Node_Id;
3288
3289                   L_Length : Uint;
3290                   R_Length : Uint;
3291
3292                begin
3293                   L_Index := First_Index (T_Typ);
3294                   R_Index := First_Index (Exptyp);
3295
3296                   for Indx in 1 .. Ndims loop
3297                      if not (Nkind (L_Index) = N_Raise_Constraint_Error
3298                                or else
3299                              Nkind (R_Index) = N_Raise_Constraint_Error)
3300                      then
3301                         Get_Index_Bounds (L_Index, L_Low, L_High);
3302                         Get_Index_Bounds (R_Index, R_Low, R_High);
3303
3304                         --  Deal with compile time length check. Note that we
3305                         --  skip this in the access case, because the access
3306                         --  value may be null, so we cannot know statically.
3307
3308                         if not Do_Access
3309                           and then Compile_Time_Known_Value (L_Low)
3310                           and then Compile_Time_Known_Value (L_High)
3311                           and then Compile_Time_Known_Value (R_Low)
3312                           and then Compile_Time_Known_Value (R_High)
3313                         then
3314                            if Expr_Value (L_High) >= Expr_Value (L_Low) then
3315                               L_Length := Expr_Value (L_High) -
3316                                           Expr_Value (L_Low) + 1;
3317                            else
3318                               L_Length := UI_From_Int (0);
3319                            end if;
3320
3321                            if Expr_Value (R_High) >= Expr_Value (R_Low) then
3322                               R_Length := Expr_Value (R_High) -
3323                                           Expr_Value (R_Low) + 1;
3324                            else
3325                               R_Length := UI_From_Int (0);
3326                            end if;
3327
3328                            if L_Length > R_Length then
3329                               Add_Check
3330                                 (Compile_Time_Constraint_Error
3331                                   (Wnode, "too few elements for}?", T_Typ));
3332
3333                            elsif  L_Length < R_Length then
3334                               Add_Check
3335                                 (Compile_Time_Constraint_Error
3336                                   (Wnode, "too many elements for}?", T_Typ));
3337                            end if;
3338
3339                         --  The comparison for an individual index subtype
3340                         --  is omitted if the corresponding index subtypes
3341                         --  statically match, since the result is known to
3342                         --  be true. Note that this test is worth while even
3343                         --  though we do static evaluation, because non-static
3344                         --  subtypes can statically match.
3345
3346                         elsif not
3347                           Subtypes_Statically_Match
3348                             (Etype (L_Index), Etype (R_Index))
3349
3350                           and then not
3351                             (Same_Bounds (L_Low, R_Low)
3352                               and then Same_Bounds (L_High, R_High))
3353                         then
3354                            Evolve_Or_Else
3355                              (Cond, Length_E_Cond (Exptyp, T_Typ, Indx));
3356                         end if;
3357
3358                         Next (L_Index);
3359                         Next (R_Index);
3360                      end if;
3361                   end loop;
3362                end;
3363
3364             --  Handle cases where we do not get a usable actual subtype that
3365             --  is constrained. This happens for example in the function call
3366             --  and explicit dereference cases. In these cases, we have to get
3367             --  the length or range from the expression itself, making sure we
3368             --  do not evaluate it more than once.
3369
3370             --  Here Ck_Node is the original expression, or more properly the
3371             --  result of applying Duplicate_Expr to the original tree,
3372             --  forcing the result to be a name.
3373
3374             else
3375                declare
3376                   Ndims : Nat := Number_Dimensions (T_Typ);
3377
3378                begin
3379                   --  Build the condition for the explicit dereference case
3380
3381                   for Indx in 1 .. Ndims loop
3382                      Evolve_Or_Else
3383                        (Cond, Length_N_Cond (Ck_Node, T_Typ, Indx));
3384                   end loop;
3385                end;
3386             end if;
3387          end if;
3388       end if;
3389
3390       --  Construct the test and insert into the tree
3391
3392       if Present (Cond) then
3393          if Do_Access then
3394             Cond := Guard_Access (Cond, Loc, Ck_Node);
3395          end if;
3396
3397          Add_Check
3398            (Make_Raise_Constraint_Error (Loc,
3399               Condition => Cond,
3400               Reason => CE_Length_Check_Failed));
3401       end if;
3402
3403       return Ret_Result;
3404    end Selected_Length_Checks;
3405
3406    ---------------------------
3407    -- Selected_Range_Checks --
3408    ---------------------------
3409
3410    function Selected_Range_Checks
3411      (Ck_Node    : Node_Id;
3412       Target_Typ : Entity_Id;
3413       Source_Typ : Entity_Id;
3414       Warn_Node  : Node_Id)
3415       return       Check_Result
3416    is
3417       Loc         : constant Source_Ptr := Sloc (Ck_Node);
3418       S_Typ       : Entity_Id;
3419       T_Typ       : Entity_Id;
3420       Expr_Actual : Node_Id;
3421       Exptyp      : Entity_Id;
3422       Cond        : Node_Id := Empty;
3423       Do_Access   : Boolean := False;
3424       Wnode       : Node_Id  := Warn_Node;
3425       Ret_Result  : Check_Result := (Empty, Empty);
3426       Num_Checks  : Integer := 0;
3427
3428       procedure Add_Check (N : Node_Id);
3429       --  Adds the action given to Ret_Result if N is non-Empty
3430
3431       function Discrete_Range_Cond
3432         (Expr : Node_Id;
3433          Typ  : Entity_Id)
3434          return Node_Id;
3435       --  Returns expression to compute:
3436       --    Low_Bound (Expr) < Typ'First
3437       --      or else
3438       --    High_Bound (Expr) > Typ'Last
3439
3440       function Discrete_Expr_Cond
3441         (Expr : Node_Id;
3442          Typ  : Entity_Id)
3443          return Node_Id;
3444       --  Returns expression to compute:
3445       --    Expr < Typ'First
3446       --      or else
3447       --    Expr > Typ'Last
3448
3449       function Get_E_First_Or_Last
3450         (E    : Entity_Id;
3451          Indx : Nat;
3452          Nam  : Name_Id)
3453          return Node_Id;
3454       --  Returns expression to compute:
3455       --    E'First or E'Last
3456
3457       function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id;
3458       function Get_N_Last  (N : Node_Id; Indx : Nat) return Node_Id;
3459       --  Returns expression to compute:
3460       --    N'First or N'Last using Duplicate_Subexpr
3461
3462       function Range_E_Cond
3463         (Exptyp : Entity_Id;
3464          Typ    : Entity_Id;
3465          Indx   : Nat)
3466          return   Node_Id;
3467       --  Returns expression to compute:
3468       --    Exptyp'First < Typ'First or else Exptyp'Last > Typ'Last
3469
3470       function Range_Equal_E_Cond
3471         (Exptyp : Entity_Id;
3472          Typ    : Entity_Id;
3473          Indx   : Nat)
3474          return   Node_Id;
3475       --  Returns expression to compute:
3476       --    Exptyp'First /= Typ'First or else Exptyp'Last /= Typ'Last
3477
3478       function Range_N_Cond
3479         (Expr : Node_Id;
3480          Typ  : Entity_Id;
3481          Indx : Nat)
3482          return Node_Id;
3483       --  Return expression to compute:
3484       --    Expr'First < Typ'First or else Expr'Last > Typ'Last
3485
3486       ---------------
3487       -- Add_Check --
3488       ---------------
3489
3490       procedure Add_Check (N : Node_Id) is
3491       begin
3492          if Present (N) then
3493
3494             --  For now, ignore attempt to place more than 2 checks ???
3495
3496             if Num_Checks = 2 then
3497                return;
3498             end if;
3499
3500             pragma Assert (Num_Checks <= 1);
3501             Num_Checks := Num_Checks + 1;
3502             Ret_Result (Num_Checks) := N;
3503          end if;
3504       end Add_Check;
3505
3506       -------------------------
3507       -- Discrete_Expr_Cond --
3508       -------------------------
3509
3510       function Discrete_Expr_Cond
3511         (Expr : Node_Id;
3512          Typ  : Entity_Id)
3513          return Node_Id
3514       is
3515       begin
3516          return
3517            Make_Or_Else (Loc,
3518              Left_Opnd =>
3519                Make_Op_Lt (Loc,
3520                  Left_Opnd =>
3521                    Convert_To (Base_Type (Typ), Duplicate_Subexpr (Expr)),
3522                  Right_Opnd =>
3523                    Convert_To (Base_Type (Typ),
3524                                Get_E_First_Or_Last (Typ, 0, Name_First))),
3525
3526              Right_Opnd =>
3527                Make_Op_Gt (Loc,
3528                  Left_Opnd =>
3529                    Convert_To (Base_Type (Typ), Duplicate_Subexpr (Expr)),
3530                  Right_Opnd =>
3531                    Convert_To
3532                      (Base_Type (Typ),
3533                       Get_E_First_Or_Last (Typ, 0, Name_Last))));
3534       end Discrete_Expr_Cond;
3535
3536       -------------------------
3537       -- Discrete_Range_Cond --
3538       -------------------------
3539
3540       function Discrete_Range_Cond
3541         (Expr : Node_Id;
3542          Typ  : Entity_Id)
3543          return Node_Id
3544       is
3545          LB : Node_Id := Low_Bound (Expr);
3546          HB : Node_Id := High_Bound (Expr);
3547
3548          Left_Opnd  : Node_Id;
3549          Right_Opnd : Node_Id;
3550
3551       begin
3552          if Nkind (LB) = N_Identifier
3553            and then Ekind (Entity (LB)) = E_Discriminant then
3554             LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
3555          end if;
3556
3557          if Nkind (HB) = N_Identifier
3558            and then Ekind (Entity (HB)) = E_Discriminant then
3559             HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
3560          end if;
3561
3562          Left_Opnd :=
3563            Make_Op_Lt (Loc,
3564              Left_Opnd  =>
3565                Convert_To
3566                  (Base_Type (Typ), Duplicate_Subexpr (LB)),
3567
3568              Right_Opnd =>
3569                Convert_To
3570                  (Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First)));
3571
3572          if Base_Type (Typ) = Typ then
3573             return Left_Opnd;
3574
3575          elsif Compile_Time_Known_Value (High_Bound (Scalar_Range (Typ)))
3576             and then
3577                Compile_Time_Known_Value (High_Bound (Scalar_Range
3578                                                      (Base_Type (Typ))))
3579          then
3580             if Is_Floating_Point_Type (Typ) then
3581                if Expr_Value_R (High_Bound (Scalar_Range (Typ))) =
3582                   Expr_Value_R (High_Bound (Scalar_Range (Base_Type (Typ))))
3583                then
3584                   return Left_Opnd;
3585                end if;
3586
3587             else
3588                if Expr_Value (High_Bound (Scalar_Range (Typ))) =
3589                   Expr_Value (High_Bound (Scalar_Range (Base_Type (Typ))))
3590                then
3591                   return Left_Opnd;
3592                end if;
3593             end if;
3594          end if;
3595
3596          Right_Opnd :=
3597            Make_Op_Gt (Loc,
3598              Left_Opnd  =>
3599                Convert_To
3600                  (Base_Type (Typ), Duplicate_Subexpr (HB)),
3601
3602              Right_Opnd =>
3603                Convert_To
3604                  (Base_Type (Typ),
3605                   Get_E_First_Or_Last (Typ, 0, Name_Last)));
3606
3607          return Make_Or_Else (Loc, Left_Opnd, Right_Opnd);
3608       end Discrete_Range_Cond;
3609
3610       -------------------------
3611       -- Get_E_First_Or_Last --
3612       -------------------------
3613
3614       function Get_E_First_Or_Last
3615         (E    : Entity_Id;
3616          Indx : Nat;
3617          Nam  : Name_Id)
3618          return Node_Id
3619       is
3620          N     : Node_Id;
3621          LB    : Node_Id;
3622          HB    : Node_Id;
3623          Bound : Node_Id;
3624
3625       begin
3626          if Is_Array_Type (E) then
3627             N := First_Index (E);
3628
3629             for J in 2 .. Indx loop
3630                Next_Index (N);
3631             end loop;
3632
3633          else
3634             N := Scalar_Range (E);
3635          end if;
3636
3637          if Nkind (N) = N_Subtype_Indication then
3638             LB := Low_Bound (Range_Expression (Constraint (N)));
3639             HB := High_Bound (Range_Expression (Constraint (N)));
3640
3641          elsif Is_Entity_Name (N) then
3642             LB := Type_Low_Bound  (Etype (N));
3643             HB := Type_High_Bound (Etype (N));
3644
3645          else
3646             LB := Low_Bound  (N);
3647             HB := High_Bound (N);
3648          end if;
3649
3650          if Nam = Name_First then
3651             Bound := LB;
3652          else
3653             Bound := HB;
3654          end if;
3655
3656          if Nkind (Bound) = N_Identifier
3657            and then Ekind (Entity (Bound)) = E_Discriminant
3658          then
3659             return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
3660
3661          elsif Nkind (Bound) = N_Identifier
3662            and then Ekind (Entity (Bound)) = E_In_Parameter
3663            and then not Inside_Init_Proc
3664          then
3665             return Get_Discriminal (E, Bound);
3666
3667          elsif Nkind (Bound) = N_Integer_Literal then
3668             return  Make_Integer_Literal (Loc, Intval (Bound));
3669
3670          else
3671             return Duplicate_Subexpr (Bound);
3672          end if;
3673       end Get_E_First_Or_Last;
3674
3675       -----------------
3676       -- Get_N_First --
3677       -----------------
3678
3679       function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id is
3680       begin
3681          return
3682            Make_Attribute_Reference (Loc,
3683              Attribute_Name => Name_First,
3684              Prefix =>
3685                Duplicate_Subexpr (N, Name_Req => True),
3686              Expressions => New_List (
3687                Make_Integer_Literal (Loc, Indx)));
3688
3689       end Get_N_First;
3690
3691       ----------------
3692       -- Get_N_Last --
3693       ----------------
3694
3695       function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id is
3696       begin
3697          return
3698            Make_Attribute_Reference (Loc,
3699              Attribute_Name => Name_Last,
3700              Prefix =>
3701                Duplicate_Subexpr (N, Name_Req => True),
3702              Expressions => New_List (
3703               Make_Integer_Literal (Loc, Indx)));
3704
3705       end Get_N_Last;
3706
3707       ------------------
3708       -- Range_E_Cond --
3709       ------------------
3710
3711       function Range_E_Cond
3712         (Exptyp : Entity_Id;
3713          Typ    : Entity_Id;
3714          Indx   : Nat)
3715          return   Node_Id
3716       is
3717       begin
3718          return
3719            Make_Or_Else (Loc,
3720              Left_Opnd =>
3721                Make_Op_Lt (Loc,
3722                  Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
3723                  Right_Opnd  => Get_E_First_Or_Last (Typ, Indx, Name_First)),
3724
3725              Right_Opnd =>
3726                Make_Op_Gt (Loc,
3727                  Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
3728                  Right_Opnd  => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
3729
3730       end Range_E_Cond;
3731
3732       ------------------------
3733       -- Range_Equal_E_Cond --
3734       ------------------------
3735
3736       function Range_Equal_E_Cond
3737         (Exptyp : Entity_Id;
3738          Typ    : Entity_Id;
3739          Indx   : Nat)
3740          return   Node_Id
3741       is
3742       begin
3743          return
3744            Make_Or_Else (Loc,
3745              Left_Opnd =>
3746                Make_Op_Ne (Loc,
3747                  Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
3748                  Right_Opnd  => Get_E_First_Or_Last (Typ, Indx, Name_First)),
3749              Right_Opnd =>
3750                Make_Op_Ne (Loc,
3751                  Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
3752                  Right_Opnd  => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
3753       end Range_Equal_E_Cond;
3754
3755       ------------------
3756       -- Range_N_Cond --
3757       ------------------
3758
3759       function Range_N_Cond
3760         (Expr : Node_Id;
3761          Typ  : Entity_Id;
3762          Indx : Nat)
3763          return Node_Id
3764       is
3765       begin
3766          return
3767            Make_Or_Else (Loc,
3768              Left_Opnd =>
3769                Make_Op_Lt (Loc,
3770                  Left_Opnd => Get_N_First (Expr, Indx),
3771                  Right_Opnd  => Get_E_First_Or_Last (Typ, Indx, Name_First)),
3772
3773              Right_Opnd =>
3774                Make_Op_Gt (Loc,
3775                  Left_Opnd => Get_N_Last (Expr, Indx),
3776                  Right_Opnd  => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
3777       end Range_N_Cond;
3778
3779    --  Start of processing for Selected_Range_Checks
3780
3781    begin
3782       if not Expander_Active then
3783          return Ret_Result;
3784       end if;
3785
3786       if Target_Typ = Any_Type
3787         or else Target_Typ = Any_Composite
3788         or else Raises_Constraint_Error (Ck_Node)
3789       then
3790          return Ret_Result;
3791       end if;
3792
3793       if No (Wnode) then
3794          Wnode := Ck_Node;
3795       end if;
3796
3797       T_Typ := Target_Typ;
3798
3799       if No (Source_Typ) then
3800          S_Typ := Etype (Ck_Node);
3801       else
3802          S_Typ := Source_Typ;
3803       end if;
3804
3805       if S_Typ = Any_Type or else S_Typ = Any_Composite then
3806          return Ret_Result;
3807       end if;
3808
3809       --  The order of evaluating T_Typ before S_Typ seems to be critical
3810       --  because S_Typ can be derived from Etype (Ck_Node), if it's not passed
3811       --  in, and since Node can be an N_Range node, it might be invalid.
3812       --  Should there be an assert check somewhere for taking the Etype of
3813       --  an N_Range node ???
3814
3815       if Is_Access_Type (T_Typ) and then Is_Access_Type (S_Typ) then
3816          S_Typ := Designated_Type (S_Typ);
3817          T_Typ := Designated_Type (T_Typ);
3818          Do_Access := True;
3819
3820          --  A simple optimization
3821
3822          if Nkind (Ck_Node) = N_Null then
3823             return Ret_Result;
3824          end if;
3825       end if;
3826
3827       --  For an N_Range Node, check for a null range and then if not
3828       --  null generate a range check action.
3829
3830       if Nkind (Ck_Node) = N_Range then
3831
3832          --  There's no point in checking a range against itself
3833
3834          if Ck_Node = Scalar_Range (T_Typ) then
3835             return Ret_Result;
3836          end if;
3837
3838          declare
3839             T_LB       : constant Node_Id := Type_Low_Bound  (T_Typ);
3840             T_HB       : constant Node_Id := Type_High_Bound (T_Typ);
3841             LB         : constant Node_Id := Low_Bound (Ck_Node);
3842             HB         : constant Node_Id := High_Bound (Ck_Node);
3843             Null_Range : Boolean;
3844
3845             Out_Of_Range_L : Boolean;
3846             Out_Of_Range_H : Boolean;
3847
3848          begin
3849             --  Check for case where everything is static and we can
3850             --  do the check at compile time. This is skipped if we
3851             --  have an access type, since the access value may be null.
3852
3853             --  ??? This code can be improved since you only need to know
3854             --  that the two respective bounds (LB & T_LB or HB & T_HB)
3855             --  are known at compile time to emit pertinent messages.
3856
3857             if Compile_Time_Known_Value (LB)
3858               and then Compile_Time_Known_Value (HB)
3859               and then Compile_Time_Known_Value (T_LB)
3860               and then Compile_Time_Known_Value (T_HB)
3861               and then not Do_Access
3862             then
3863                --  Floating-point case
3864
3865                if Is_Floating_Point_Type (S_Typ) then
3866                   Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB);
3867                   Out_Of_Range_L :=
3868                     (Expr_Value_R (LB) < Expr_Value_R (T_LB))
3869                        or else
3870                     (Expr_Value_R (LB) > Expr_Value_R (T_HB));
3871
3872                   Out_Of_Range_H :=
3873                     (Expr_Value_R (HB) > Expr_Value_R (T_HB))
3874                        or else
3875                     (Expr_Value_R (HB) < Expr_Value_R (T_LB));
3876
3877                --  Fixed or discrete type case
3878
3879                else
3880                   Null_Range := Expr_Value (HB) < Expr_Value (LB);
3881                   Out_Of_Range_L :=
3882                     (Expr_Value (LB) < Expr_Value (T_LB))
3883                     or else
3884                     (Expr_Value (LB) > Expr_Value (T_HB));
3885
3886                   Out_Of_Range_H :=
3887                     (Expr_Value (HB) > Expr_Value (T_HB))
3888                     or else
3889                     (Expr_Value (HB) < Expr_Value (T_LB));
3890                end if;
3891
3892                if not Null_Range then
3893                   if Out_Of_Range_L then
3894                      if No (Warn_Node) then
3895                         Add_Check
3896                           (Compile_Time_Constraint_Error
3897                              (Low_Bound (Ck_Node),
3898                               "static value out of range of}?", T_Typ));
3899
3900                      else
3901                         Add_Check
3902                           (Compile_Time_Constraint_Error
3903                             (Wnode,
3904                              "static range out of bounds of}?", T_Typ));
3905                      end if;
3906                   end if;
3907
3908                   if Out_Of_Range_H then
3909                      if No (Warn_Node) then
3910                         Add_Check
3911                           (Compile_Time_Constraint_Error
3912                              (High_Bound (Ck_Node),
3913                               "static value out of range of}?", T_Typ));
3914
3915                      else
3916                         Add_Check
3917                           (Compile_Time_Constraint_Error
3918                              (Wnode,
3919                               "static range out of bounds of}?", T_Typ));
3920                      end if;
3921                   end if;
3922
3923                end if;
3924
3925             else
3926                declare
3927                   LB : Node_Id := Low_Bound (Ck_Node);
3928                   HB : Node_Id := High_Bound (Ck_Node);
3929
3930                begin
3931
3932                   --  If either bound is a discriminant and we are within
3933                   --  the record declaration, it is a use of the discriminant
3934                   --  in a constraint of a component, and nothing can be
3935                   --  checked here. The check will be emitted within the
3936                   --  init_proc. Before then, the discriminal has no real
3937                   --  meaning.
3938
3939                   if Nkind (LB) = N_Identifier
3940                     and then Ekind (Entity (LB)) = E_Discriminant
3941                   then
3942                      if Current_Scope = Scope (Entity (LB)) then
3943                         return Ret_Result;
3944                      else
3945                         LB :=
3946                           New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
3947                      end if;
3948                   end if;
3949
3950                   if Nkind (HB) = N_Identifier
3951                     and then Ekind (Entity (HB)) = E_Discriminant
3952                   then
3953                      if Current_Scope = Scope (Entity (HB)) then
3954                         return Ret_Result;
3955                      else
3956                         HB :=
3957                           New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
3958                      end if;
3959                   end if;
3960
3961                   Cond := Discrete_Range_Cond (Ck_Node, T_Typ);
3962                   Set_Paren_Count (Cond, 1);
3963
3964                   Cond :=
3965                     Make_And_Then (Loc,
3966                       Left_Opnd =>
3967                         Make_Op_Ge (Loc,
3968                           Left_Opnd  => Duplicate_Subexpr (HB),
3969                           Right_Opnd => Duplicate_Subexpr (LB)),
3970                       Right_Opnd => Cond);
3971                end;
3972
3973             end if;
3974          end;
3975
3976       elsif Is_Scalar_Type (S_Typ) then
3977
3978          --  This somewhat duplicates what Apply_Scalar_Range_Check does,
3979          --  except the above simply sets a flag in the node and lets
3980          --  gigi generate the check base on the Etype of the expression.
3981          --  Sometimes, however we want to do a dynamic check against an
3982          --  arbitrary target type, so we do that here.
3983
3984          if Ekind (Base_Type (S_Typ)) /= Ekind (Base_Type (T_Typ)) then
3985             Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
3986
3987          --  For literals, we can tell if the constraint error will be
3988          --  raised at compile time, so we never need a dynamic check, but
3989          --  if the exception will be raised, then post the usual warning,
3990          --  and replace the literal with a raise constraint error
3991          --  expression. As usual, skip this for access types
3992
3993          elsif Compile_Time_Known_Value (Ck_Node)
3994            and then not Do_Access
3995          then
3996             declare
3997                LB : constant Node_Id := Type_Low_Bound (T_Typ);
3998                UB : constant Node_Id := Type_High_Bound (T_Typ);
3999
4000                Out_Of_Range  : Boolean;
4001                Static_Bounds : constant Boolean :=
4002                                  Compile_Time_Known_Value (LB)
4003                                    and Compile_Time_Known_Value (UB);
4004
4005             begin
4006                --  Following range tests should use Sem_Eval routine ???
4007
4008                if Static_Bounds then
4009                   if Is_Floating_Point_Type (S_Typ) then
4010                      Out_Of_Range :=
4011                        (Expr_Value_R (Ck_Node) < Expr_Value_R (LB))
4012                          or else
4013                        (Expr_Value_R (Ck_Node) > Expr_Value_R (UB));
4014
4015                   else -- fixed or discrete type
4016                      Out_Of_Range :=
4017                        Expr_Value (Ck_Node) < Expr_Value (LB)
4018                          or else
4019                        Expr_Value (Ck_Node) > Expr_Value (UB);
4020                   end if;
4021
4022                   --  Bounds of the type are static and the literal is
4023                   --  out of range so make a warning message.
4024
4025                   if Out_Of_Range then
4026                      if No (Warn_Node) then
4027                         Add_Check
4028                           (Compile_Time_Constraint_Error
4029                              (Ck_Node,
4030                               "static value out of range of}?", T_Typ));
4031
4032                      else
4033                         Add_Check
4034                           (Compile_Time_Constraint_Error
4035                              (Wnode,
4036                               "static value out of range of}?", T_Typ));
4037                      end if;
4038                   end if;
4039
4040                else
4041                   Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
4042                end if;
4043             end;
4044
4045          --  Here for the case of a non-static expression, we need a runtime
4046          --  check unless the source type range is guaranteed to be in the
4047          --  range of the target type.
4048
4049          else
4050             if not In_Subrange_Of (S_Typ, T_Typ) then
4051                Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
4052             end if;
4053          end if;
4054       end if;
4055
4056       if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then
4057          if Is_Constrained (T_Typ) then
4058
4059             Expr_Actual := Get_Referenced_Object (Ck_Node);
4060             Exptyp      := Get_Actual_Subtype (Expr_Actual);
4061
4062             if Is_Access_Type (Exptyp) then
4063                Exptyp := Designated_Type (Exptyp);
4064             end if;
4065
4066             --  String_Literal case. This needs to be handled specially be-
4067             --  cause no index types are available for string literals. The
4068             --  condition is simply:
4069
4070             --    T_Typ'Length = string-literal-length
4071
4072             if Nkind (Expr_Actual) = N_String_Literal then
4073                null;
4074
4075             --  General array case. Here we have a usable actual subtype for
4076             --  the expression, and the condition is built from the two types
4077
4078             --     T_Typ'First     < Exptyp'First     or else
4079             --     T_Typ'Last      > Exptyp'Last      or else
4080             --     T_Typ'First(1)  < Exptyp'First(1)  or else
4081             --     T_Typ'Last(1)   > Exptyp'Last(1)   or else
4082             --     ...
4083
4084             elsif Is_Constrained (Exptyp) then
4085                declare
4086                   L_Index : Node_Id;
4087                   R_Index : Node_Id;
4088                   Ndims   : Nat := Number_Dimensions (T_Typ);
4089
4090                   L_Low  : Node_Id;
4091                   L_High : Node_Id;
4092                   R_Low  : Node_Id;
4093                   R_High : Node_Id;
4094
4095                begin
4096                   L_Index := First_Index (T_Typ);
4097                   R_Index := First_Index (Exptyp);
4098
4099                   for Indx in 1 .. Ndims loop
4100                      if not (Nkind (L_Index) = N_Raise_Constraint_Error
4101                                or else
4102                              Nkind (R_Index) = N_Raise_Constraint_Error)
4103                      then
4104                         Get_Index_Bounds (L_Index, L_Low, L_High);
4105                         Get_Index_Bounds (R_Index, R_Low, R_High);
4106
4107                         --  Deal with compile time length check. Note that we
4108                         --  skip this in the access case, because the access
4109                         --  value may be null, so we cannot know statically.
4110
4111                         if not
4112                           Subtypes_Statically_Match
4113                             (Etype (L_Index), Etype (R_Index))
4114                         then
4115                            --  If the target type is constrained then we
4116                            --  have to check for exact equality of bounds
4117                            --  (required for qualified expressions).
4118
4119                            if Is_Constrained (T_Typ) then
4120                               Evolve_Or_Else
4121                                 (Cond,
4122                                  Range_Equal_E_Cond (Exptyp, T_Typ, Indx));
4123
4124                            else
4125                               Evolve_Or_Else
4126                                 (Cond, Range_E_Cond (Exptyp, T_Typ, Indx));
4127                            end if;
4128                         end if;
4129
4130                         Next (L_Index);
4131                         Next (R_Index);
4132
4133                      end if;
4134                   end loop;
4135                end;
4136
4137             --  Handle cases where we do not get a usable actual subtype that
4138             --  is constrained. This happens for example in the function call
4139             --  and explicit dereference cases. In these cases, we have to get
4140             --  the length or range from the expression itself, making sure we
4141             --  do not evaluate it more than once.
4142
4143             --  Here Ck_Node is the original expression, or more properly the
4144             --  result of applying Duplicate_Expr to the original tree,
4145             --  forcing the result to be a name.
4146
4147             else
4148                declare
4149                   Ndims   : Nat := Number_Dimensions (T_Typ);
4150
4151                begin
4152                   --  Build the condition for the explicit dereference case
4153
4154                   for Indx in 1 .. Ndims loop
4155                      Evolve_Or_Else
4156                        (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx));
4157                   end loop;
4158                end;
4159
4160             end if;
4161
4162          else
4163             --  Generate an Action to check that the bounds of the
4164             --  source value are within the constraints imposed by the
4165             --  target type for a conversion to an unconstrained type.
4166             --  Rule is 4.6(38).
4167
4168             if Nkind (Parent (Ck_Node)) = N_Type_Conversion then
4169                declare
4170                   Opnd_Index : Node_Id;
4171                   Targ_Index : Node_Id;
4172
4173                begin
4174                   Opnd_Index
4175                     := First_Index (Get_Actual_Subtype (Ck_Node));
4176                   Targ_Index := First_Index (T_Typ);
4177
4178                   while Opnd_Index /= Empty loop
4179                      if Nkind (Opnd_Index) = N_Range then
4180                         if Is_In_Range
4181                              (Low_Bound (Opnd_Index), Etype (Targ_Index))
4182                           and then
4183                             Is_In_Range
4184                              (High_Bound (Opnd_Index), Etype (Targ_Index))
4185                         then
4186                            null;
4187
4188                         elsif Is_Out_Of_Range
4189                                 (Low_Bound (Opnd_Index), Etype (Targ_Index))
4190                           or else
4191                               Is_Out_Of_Range
4192                                 (High_Bound (Opnd_Index), Etype (Targ_Index))
4193                         then
4194                            Add_Check
4195                              (Compile_Time_Constraint_Error
4196                                (Wnode, "value out of range of}?", T_Typ));
4197
4198                         else
4199                            Evolve_Or_Else
4200                              (Cond,
4201                               Discrete_Range_Cond
4202                                 (Opnd_Index, Etype (Targ_Index)));
4203                         end if;
4204                      end if;
4205
4206                      Next_Index (Opnd_Index);
4207                      Next_Index (Targ_Index);
4208                   end loop;
4209                end;
4210             end if;
4211          end if;
4212       end if;
4213
4214       --  Construct the test and insert into the tree
4215
4216       if Present (Cond) then
4217          if Do_Access then
4218             Cond := Guard_Access (Cond, Loc, Ck_Node);
4219          end if;
4220
4221          Add_Check
4222            (Make_Raise_Constraint_Error (Loc,
4223               Condition => Cond,
4224               Reason    => CE_Range_Check_Failed));
4225       end if;
4226
4227       return Ret_Result;
4228    end Selected_Range_Checks;
4229
4230    -------------------------------
4231    -- Storage_Checks_Suppressed --
4232    -------------------------------
4233
4234    function Storage_Checks_Suppressed (E : Entity_Id) return Boolean is
4235    begin
4236       return Scope_Suppress.Storage_Checks
4237         or else (Present (E) and then Suppress_Storage_Checks (E));
4238    end Storage_Checks_Suppressed;
4239
4240    ---------------------------
4241    -- Tag_Checks_Suppressed --
4242    ---------------------------
4243
4244    function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
4245    begin
4246       return Scope_Suppress.Tag_Checks
4247         or else (Present (E) and then Suppress_Tag_Checks (E));
4248    end Tag_Checks_Suppressed;
4249
4250 end Checks;