gcc/ada/checks.adb

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