gcc/ada/checks.adb

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