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