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