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