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