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