gcc/ada/sem_eval.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ E V A L                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Checks;   use Checks;
  28 with Debug;    use Debug;
  29 with Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Errout;   use Errout;
  32 with Eval_Fat; use Eval_Fat;
  33 with Exp_Util; use Exp_Util;
  34 with Lib;      use Lib;
  35 with Namet;    use Namet;
  36 with Nmake;    use Nmake;
  37 with Nlists;   use Nlists;
  38 with Opt;      use Opt;
  39 with Sem;      use Sem;
  40 with Sem_Aux;  use Sem_Aux;
  41 with Sem_Cat;  use Sem_Cat;
  42 with Sem_Ch6;  use Sem_Ch6;
  43 with Sem_Ch8;  use Sem_Ch8;
  44 with Sem_Res;  use Sem_Res;
  45 with Sem_Util; use Sem_Util;
  46 with Sem_Type; use Sem_Type;
  47 with Sem_Warn; use Sem_Warn;
  48 with Sinfo;    use Sinfo;
  49 with Snames;   use Snames;
  50 with Stand;    use Stand;
  51 with Stringt;  use Stringt;
  52 with Tbuild;   use Tbuild;
  53
  54 package body Sem_Eval is
  55
  56    -----------------------------------------
  57    -- Handling of Compile Time Evaluation --
  58    -----------------------------------------
  59
  60    --  The compile time evaluation of expressions is distributed over several
  61    --  Eval_xxx procedures. These procedures are called immediately after
  62    --  a subexpression is resolved and is therefore accomplished in a bottom
  63    --  up fashion. The flags are synthesized using the following approach.
  64
  65    --    Is_Static_Expression is determined by following the detailed rules
  66    --    in RM 4.9(4-14). This involves testing the Is_Static_Expression
  67    --    flag of the operands in many cases.
  68
  69    --    Raises_Constraint_Error is set if any of the operands have the flag
  70    --    set or if an attempt to compute the value of the current expression
  71    --    results in detection of a runtime constraint error.
  72
  73    --  As described in the spec, the requirement is that Is_Static_Expression
  74    --  be accurately set, and in addition for nodes for which this flag is set,
  75    --  Raises_Constraint_Error must also be set. Furthermore a node which has
  76    --  Is_Static_Expression set, and Raises_Constraint_Error clear, then the
  77    --  requirement is that the expression value must be precomputed, and the
  78    --  node is either a literal, or the name of a constant entity whose value
  79    --  is a static expression.
  80
  81    --  The general approach is as follows. First compute Is_Static_Expression.
  82    --  If the node is not static, then the flag is left off in the node and
  83    --  we are all done. Otherwise for a static node, we test if any of the
  84    --  operands will raise constraint error, and if so, propagate the flag
  85    --  Raises_Constraint_Error to the result node and we are done (since the
  86    --  error was already posted at a lower level).
  87
  88    --  For the case of a static node whose operands do not raise constraint
  89    --  error, we attempt to evaluate the node. If this evaluation succeeds,
  90    --  then the node is replaced by the result of this computation. If the
  91    --  evaluation raises constraint error, then we rewrite the node with
  92    --  Apply_Compile_Time_Constraint_Error to raise the exception and also
  93    --  to post appropriate error messages.
  94
  95    ----------------
  96    -- Local Data --
  97    ----------------
  98
  99    type Bits is array (Nat range <>) of Boolean;
 100    --  Used to convert unsigned (modular) values for folding logical ops
 101
 102    --  The following definitions are used to maintain a cache of nodes that
 103    --  have compile time known values. The cache is maintained only for
 104    --  discrete types (the most common case), and is populated by calls to
 105    --  Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
 106    --  since it is possible for the status to change (in particular it is
 107    --  possible for a node to get replaced by a constraint error node).
 108
 109    CV_Bits : constant := 5;
 110    --  Number of low order bits of Node_Id value used to reference entries
 111    --  in the cache table.
 112
 113    CV_Cache_Size : constant Nat := 2 ** CV_Bits;
 114    --  Size of cache for compile time values
 115
 116    subtype CV_Range is Nat range 0 .. CV_Cache_Size;
 117
 118    type CV_Entry is record
 119       N : Node_Id;
 120       V : Uint;
 121    end record;
 122
 123    type CV_Cache_Array is array (CV_Range) of CV_Entry;
 124
 125    CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0));
 126    --  This is the actual cache, with entries consisting of node/value pairs,
 127    --  and the impossible value Node_High_Bound used for unset entries.
 128
 129    -----------------------
 130    -- Local Subprograms --
 131    -----------------------
 132
 133    function From_Bits (B : Bits; T : Entity_Id) return Uint;
 134    --  Converts a bit string of length B'Length to a Uint value to be used
 135    --  for a target of type T, which is a modular type. This procedure
 136    --  includes the necessary reduction by the modulus in the case of a
 137    --  non-binary modulus (for a binary modulus, the bit string is the
 138    --  right length any way so all is well).
 139
 140    function Get_String_Val (N : Node_Id) return Node_Id;
 141    --  Given a tree node for a folded string or character value, returns
 142    --  the corresponding string literal or character literal (one of the
 143    --  two must be available, or the operand would not have been marked
 144    --  as foldable in the earlier analysis of the operation).
 145
 146    function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
 147    --  Bits represents the number of bits in an integer value to be computed
 148    --  (but the value has not been computed yet). If this value in Bits is
 149    --  reasonable, a result of True is returned, with the implication that
 150    --  the caller should go ahead and complete the calculation. If the value
 151    --  in Bits is unreasonably large, then an error is posted on node N, and
 152    --  False is returned (and the caller skips the proposed calculation).
 153
 154    procedure Out_Of_Range (N : Node_Id);
 155    --  This procedure is called if it is determined that node N, which
 156    --  appears in a non-static context, is a compile time known value
 157    --  which is outside its range, i.e. the range of Etype. This is used
 158    --  in contexts where this is an illegality if N is static, and should
 159    --  generate a warning otherwise.
 160
 161    procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
 162    --  N and Exp are nodes representing an expression, Exp is known
 163    --  to raise CE. N is rewritten in term of Exp in the optimal way.
 164
 165    function String_Type_Len (Stype : Entity_Id) return Uint;
 166    --  Given a string type, determines the length of the index type, or,
 167    --  if this index type is non-static, the length of the base type of
 168    --  this index type. Note that if the string type is itself static,
 169    --  then the index type is static, so the second case applies only
 170    --  if the string type passed is non-static.
 171
 172    function Test (Cond : Boolean) return Uint;
 173    pragma Inline (Test);
 174    --  This function simply returns the appropriate Boolean'Pos value
 175    --  corresponding to the value of Cond as a universal integer. It is
 176    --  used for producing the result of the static evaluation of the
 177    --  logical operators
 178
 179    procedure Test_Expression_Is_Foldable
 180      (N    : Node_Id;
 181       Op1  : Node_Id;
 182       Stat : out Boolean;
 183       Fold : out Boolean);
 184    --  Tests to see if expression N whose single operand is Op1 is foldable,
 185    --  i.e. the operand value is known at compile time. If the operation is
 186    --  foldable, then Fold is True on return, and Stat indicates whether
 187    --  the result is static (i.e. both operands were static). Note that it
 188    --  is quite possible for Fold to be True, and Stat to be False, since
 189    --  there are cases in which we know the value of an operand even though
 190    --  it is not technically static (e.g. the static lower bound of a range
 191    --  whose upper bound is non-static).
 192    --
 193    --  If Stat is set False on return, then Test_Expression_Is_Foldable makes a
 194    --  call to Check_Non_Static_Context on the operand. If Fold is False on
 195    --  return, then all processing is complete, and the caller should
 196    --  return, since there is nothing else to do.
 197    --
 198    --  If Stat is set True on return, then Is_Static_Expression is also set
 199    --  true in node N. There are some cases where this is over-enthusiastic,
 200    --  e.g. in the two operand case below, for string comaprison, the result
 201    --  is not static even though the two operands are static. In such cases,
 202    --  the caller must reset the Is_Static_Expression flag in N.
 203
 204    procedure Test_Expression_Is_Foldable
 205      (N    : Node_Id;
 206       Op1  : Node_Id;
 207       Op2  : Node_Id;
 208       Stat : out Boolean;
 209       Fold : out Boolean);
 210    --  Same processing, except applies to an expression N with two operands
 211    --  Op1 and Op2.
 212
 213    procedure To_Bits (U : Uint; B : out Bits);
 214    --  Converts a Uint value to a bit string of length B'Length
 215
 216    ------------------------------
 217    -- Check_Non_Static_Context --
 218    ------------------------------
 219
 220    procedure Check_Non_Static_Context (N : Node_Id) is
 221       T         : constant Entity_Id := Etype (N);
 222       Checks_On : constant Boolean   :=
 223                     not Index_Checks_Suppressed (T)
 224                       and not Range_Checks_Suppressed (T);
 225
 226    begin
 227       --  Ignore cases of non-scalar types or error types
 228
 229       if T = Any_Type or else not Is_Scalar_Type (T) then
 230          return;
 231       end if;
 232
 233       --  At this stage we have a scalar type. If we have an expression
 234       --  that raises CE, then we already issued a warning or error msg
 235       --  so there is nothing more to be done in this routine.
 236
 237       if Raises_Constraint_Error (N) then
 238          return;
 239       end if;
 240
 241       --  Now we have a scalar type which is not marked as raising a
 242       --  constraint error exception. The main purpose of this routine
 243       --  is to deal with static expressions appearing in a non-static
 244       --  context. That means that if we do not have a static expression
 245       --  then there is not much to do. The one case that we deal with
 246       --  here is that if we have a floating-point value that is out of
 247       --  range, then we post a warning that an infinity will result.
 248
 249       if not Is_Static_Expression (N) then
 250          if Is_Floating_Point_Type (T)
 251            and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
 252          then
 253             Error_Msg_N
 254               ("?float value out of range, infinity will be generated", N);
 255          end if;
 256
 257          return;
 258       end if;
 259
 260       --  Here we have the case of outer level static expression of
 261       --  scalar type, where the processing of this procedure is needed.
 262
 263       --  For real types, this is where we convert the value to a machine
 264       --  number (see RM 4.9(38)). Also see ACVC test C490001. We should
 265       --  only need to do this if the parent is a constant declaration,
 266       --  since in other cases, gigi should do the necessary conversion
 267       --  correctly, but experimentation shows that this is not the case
 268       --  on all machines, in particular if we do not convert all literals
 269       --  to machine values in non-static contexts, then ACVC test C490001
 270       --  fails on Sparc/Solaris and SGI/Irix.
 271
 272       if Nkind (N) = N_Real_Literal
 273         and then not Is_Machine_Number (N)
 274         and then not Is_Generic_Type (Etype (N))
 275         and then Etype (N) /= Universal_Real
 276       then
 277          --  Check that value is in bounds before converting to machine
 278          --  number, so as not to lose case where value overflows in the
 279          --  least significant bit or less. See B490001.
 280
 281          if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
 282             Out_Of_Range (N);
 283             return;
 284          end if;
 285
 286          --  Note: we have to copy the node, to avoid problems with conformance
 287          --  of very similar numbers (see ACVC tests B4A010C and B63103A).
 288
 289          Rewrite (N, New_Copy (N));
 290
 291          if not Is_Floating_Point_Type (T) then
 292             Set_Realval
 293               (N, Corresponding_Integer_Value (N) * Small_Value (T));
 294
 295          elsif not UR_Is_Zero (Realval (N)) then
 296
 297             --  Note: even though RM 4.9(38) specifies biased rounding,
 298             --  this has been modified by AI-100 in order to prevent
 299             --  confusing differences in rounding between static and
 300             --  non-static expressions. AI-100 specifies that the effect
 301             --  of such rounding is implementation dependent, and in GNAT
 302             --  we round to nearest even to match the run-time behavior.
 303
 304             Set_Realval
 305               (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
 306          end if;
 307
 308          Set_Is_Machine_Number (N);
 309       end if;
 310
 311       --  Check for out of range universal integer. This is a non-static
 312       --  context, so the integer value must be in range of the runtime
 313       --  representation of universal integers.
 314
 315       --  We do this only within an expression, because that is the only
 316       --  case in which non-static universal integer values can occur, and
 317       --  furthermore, Check_Non_Static_Context is currently (incorrectly???)
 318       --  called in contexts like the expression of a number declaration where
 319       --  we certainly want to allow out of range values.
 320
 321       if Etype (N) = Universal_Integer
 322         and then Nkind (N) = N_Integer_Literal
 323         and then Nkind (Parent (N)) in N_Subexpr
 324         and then
 325           (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
 326             or else
 327            Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
 328       then
 329          Apply_Compile_Time_Constraint_Error
 330            (N, "non-static universal integer value out of range?",
 331             CE_Range_Check_Failed);
 332
 333       --  Check out of range of base type
 334
 335       elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
 336          Out_Of_Range (N);
 337
 338       --  Give warning if outside subtype (where one or both of the bounds of
 339       --  the subtype is static). This warning is omitted if the expression
 340       --  appears in a range that could be null (warnings are handled elsewhere
 341       --  for this case).
 342
 343       elsif T /= Base_Type (T)
 344         and then Nkind (Parent (N)) /= N_Range
 345       then
 346          if Is_In_Range (N, T, Assume_Valid => True) then
 347             null;
 348
 349          elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
 350             Apply_Compile_Time_Constraint_Error
 351               (N, "value not in range of}?", CE_Range_Check_Failed);
 352
 353          elsif Checks_On then
 354             Enable_Range_Check (N);
 355
 356          else
 357             Set_Do_Range_Check (N, False);
 358          end if;
 359       end if;
 360    end Check_Non_Static_Context;
 361
 362    ---------------------------------
 363    -- Check_String_Literal_Length --
 364    ---------------------------------
 365
 366    procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
 367    begin
 368       if not Raises_Constraint_Error (N)
 369         and then Is_Constrained (Ttype)
 370       then
 371          if
 372            UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
 373          then
 374             Apply_Compile_Time_Constraint_Error
 375               (N, "string length wrong for}?",
 376                CE_Length_Check_Failed,
 377                Ent => Ttype,
 378                Typ => Ttype);
 379          end if;
 380       end if;
 381    end Check_String_Literal_Length;
 382
 383    --------------------------
 384    -- Compile_Time_Compare --
 385    --------------------------
 386
 387    function Compile_Time_Compare
 388      (L, R         : Node_Id;
 389       Assume_Valid : Boolean) return Compare_Result
 390    is
 391       Discard : aliased Uint;
 392    begin
 393       return Compile_Time_Compare (L, R, Discard'Access, Assume_Valid);
 394    end Compile_Time_Compare;
 395
 396    function Compile_Time_Compare
 397      (L, R         : Node_Id;
 398       Diff         : access Uint;
 399       Assume_Valid : Boolean;
 400       Rec          : Boolean := False) return Compare_Result
 401    is
 402       Ltyp : Entity_Id := Underlying_Type (Etype (L));
 403       Rtyp : Entity_Id := Underlying_Type (Etype (R));
 404       --  These get reset to the base type for the case of entities where
 405       --  Is_Known_Valid is not set. This takes care of handling possible
 406       --  invalid representations using the value of the base type, in
 407       --  accordance with RM 13.9.1(10).
 408
 409       Discard : aliased Uint;
 410
 411       procedure Compare_Decompose
 412         (N : Node_Id;
 413          R : out Node_Id;
 414          V : out Uint);
 415       --  This procedure decomposes the node N into an expression node and a
 416       --  signed offset, so that the value of N is equal to the value of R plus
 417       --  the value V (which may be negative). If no such decomposition is
 418       --  possible, then on return R is a copy of N, and V is set to zero.
 419
 420       function Compare_Fixup (N : Node_Id) return Node_Id;
 421       --  This function deals with replacing 'Last and 'First references with
 422       --  their corresponding type bounds, which we then can compare. The
 423       --  argument is the original node, the result is the identity, unless we
 424       --  have a 'Last/'First reference in which case the value returned is the
 425       --  appropriate type bound.
 426
 427       function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean;
 428       --  Even if the context does not assume that values are valid, some
 429       --  simple cases can be recognized.
 430
 431       function Is_Same_Value (L, R : Node_Id) return Boolean;
 432       --  Returns True iff L and R represent expressions that definitely
 433       --  have identical (but not necessarily compile time known) values
 434       --  Indeed the caller is expected to have already dealt with the
 435       --  cases of compile time known values, so these are not tested here.
 436
 437       -----------------------
 438       -- Compare_Decompose --
 439       -----------------------
 440
 441       procedure Compare_Decompose
 442         (N : Node_Id;
 443          R : out Node_Id;
 444          V : out Uint)
 445       is
 446       begin
 447          if Nkind (N) = N_Op_Add
 448            and then Nkind (Right_Opnd (N)) = N_Integer_Literal
 449          then
 450             R := Left_Opnd (N);
 451             V := Intval (Right_Opnd (N));
 452             return;
 453
 454          elsif Nkind (N) = N_Op_Subtract
 455            and then Nkind (Right_Opnd (N)) = N_Integer_Literal
 456          then
 457             R := Left_Opnd (N);
 458             V := UI_Negate (Intval (Right_Opnd (N)));
 459             return;
 460
 461          elsif Nkind (N) = N_Attribute_Reference  then
 462             if Attribute_Name (N) = Name_Succ then
 463                R := First (Expressions (N));
 464                V := Uint_1;
 465                return;
 466
 467             elsif Attribute_Name (N) = Name_Pred then
 468                R := First (Expressions (N));
 469                V := Uint_Minus_1;
 470                return;
 471             end if;
 472          end if;
 473
 474          R := N;
 475          V := Uint_0;
 476       end Compare_Decompose;
 477
 478       -------------------
 479       -- Compare_Fixup --
 480       -------------------
 481
 482       function Compare_Fixup (N : Node_Id) return Node_Id is
 483          Indx : Node_Id;
 484          Xtyp : Entity_Id;
 485          Subs : Nat;
 486
 487       begin
 488          if Nkind (N) = N_Attribute_Reference
 489            and then (Attribute_Name (N) = Name_First
 490                        or else
 491                      Attribute_Name (N) = Name_Last)
 492          then
 493             Xtyp := Etype (Prefix (N));
 494
 495             --  If we have no type, then just abandon the attempt to do
 496             --  a fixup, this is probably the result of some other error.
 497
 498             if No (Xtyp) then
 499                return N;
 500             end if;
 501
 502             --  Dereference an access type
 503
 504             if Is_Access_Type (Xtyp) then
 505                Xtyp := Designated_Type (Xtyp);
 506             end if;
 507
 508             --  If we don't have an array type at this stage, something
 509             --  is peculiar, e.g. another error, and we abandon the attempt
 510             --  at a fixup.
 511
 512             if not Is_Array_Type (Xtyp) then
 513                return N;
 514             end if;
 515
 516             --  Ignore unconstrained array, since bounds are not meaningful
 517
 518             if not Is_Constrained (Xtyp) then
 519                return N;
 520             end if;
 521
 522             if Ekind (Xtyp) = E_String_Literal_Subtype then
 523                if Attribute_Name (N) = Name_First then
 524                   return String_Literal_Low_Bound (Xtyp);
 525
 526                else         -- Attribute_Name (N) = Name_Last
 527                   return Make_Integer_Literal (Sloc (N),
 528                     Intval => Intval (String_Literal_Low_Bound (Xtyp))
 529                                 + String_Literal_Length (Xtyp));
 530                end if;
 531             end if;
 532
 533             --  Find correct index type
 534
 535             Indx := First_Index (Xtyp);
 536
 537             if Present (Expressions (N)) then
 538                Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
 539
 540                for J in 2 .. Subs loop
 541                   Indx := Next_Index (Indx);
 542                end loop;
 543             end if;
 544
 545             Xtyp := Etype (Indx);
 546
 547             if Attribute_Name (N) = Name_First then
 548                return Type_Low_Bound (Xtyp);
 549
 550             else -- Attribute_Name (N) = Name_Last
 551                return Type_High_Bound (Xtyp);
 552             end if;
 553          end if;
 554
 555          return N;
 556       end Compare_Fixup;
 557
 558       ----------------------------
 559       -- Is_Known_Valid_Operand --
 560       ----------------------------
 561
 562       function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean is
 563       begin
 564          return (Is_Entity_Name (Opnd)
 565                   and then
 566                     (Is_Known_Valid (Entity (Opnd))
 567                       or else Ekind (Entity (Opnd)) = E_In_Parameter
 568                       or else
 569                         (Ekind (Entity (Opnd)) in Object_Kind
 570                            and then Present (Current_Value (Entity (Opnd))))))
 571            or else Is_OK_Static_Expression (Opnd);
 572       end Is_Known_Valid_Operand;
 573
 574       -------------------
 575       -- Is_Same_Value --
 576       -------------------
 577
 578       function Is_Same_Value (L, R : Node_Id) return Boolean is
 579          Lf : constant Node_Id := Compare_Fixup (L);
 580          Rf : constant Node_Id := Compare_Fixup (R);
 581
 582          function Is_Same_Subscript (L, R : List_Id) return Boolean;
 583          --  L, R are the Expressions values from two attribute nodes for First
 584          --  or Last attributes. Either may be set to No_List if no expressions
 585          --  are present (indicating subscript 1). The result is True if both
 586          --  expressions represent the same subscript (note one case is where
 587          --  one subscript is missing and the other is explicitly set to 1).
 588
 589          -----------------------
 590          -- Is_Same_Subscript --
 591          -----------------------
 592
 593          function Is_Same_Subscript (L, R : List_Id) return Boolean is
 594          begin
 595             if L = No_List then
 596                if R = No_List then
 597                   return True;
 598                else
 599                   return Expr_Value (First (R)) = Uint_1;
 600                end if;
 601
 602             else
 603                if R = No_List then
 604                   return Expr_Value (First (L)) = Uint_1;
 605                else
 606                   return Expr_Value (First (L)) = Expr_Value (First (R));
 607                end if;
 608             end if;
 609          end Is_Same_Subscript;
 610
 611       --  Start of processing for Is_Same_Value
 612
 613       begin
 614          --  Values are the same if they refer to the same entity and the
 615          --  entity is non-volatile. This does not however apply to Float
 616          --  types, since we may have two NaN values and they should never
 617          --  compare equal.
 618
 619          if Nkind_In (Lf, N_Identifier, N_Expanded_Name)
 620            and then Nkind_In (Rf, N_Identifier, N_Expanded_Name)
 621            and then Entity (Lf) = Entity (Rf)
 622            and then Present (Entity (Lf))
 623            and then not Is_Floating_Point_Type (Etype (L))
 624            and then not Is_Volatile_Reference (L)
 625            and then not Is_Volatile_Reference (R)
 626          then
 627             return True;
 628
 629          --  Or if they are compile time known and identical
 630
 631          elsif Compile_Time_Known_Value (Lf)
 632                  and then
 633                Compile_Time_Known_Value (Rf)
 634            and then Expr_Value (Lf) = Expr_Value (Rf)
 635          then
 636             return True;
 637
 638          --  False if Nkind of the two nodes is different for remaining cases
 639
 640          elsif Nkind (Lf) /= Nkind (Rf) then
 641             return False;
 642
 643          --  True if both 'First or 'Last values applying to the same entity
 644          --  (first and last don't change even if value does). Note that we
 645          --  need this even with the calls to Compare_Fixup, to handle the
 646          --  case of unconstrained array attributes where Compare_Fixup
 647          --  cannot find useful bounds.
 648
 649          elsif Nkind (Lf) = N_Attribute_Reference
 650            and then Attribute_Name (Lf) = Attribute_Name (Rf)
 651            and then (Attribute_Name (Lf) = Name_First
 652                        or else
 653                      Attribute_Name (Lf) = Name_Last)
 654            and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name)
 655            and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name)
 656            and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
 657            and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
 658          then
 659             return True;
 660
 661          --  True if the same selected component from the same record
 662
 663          elsif Nkind (Lf) = N_Selected_Component
 664            and then Selector_Name (Lf) = Selector_Name (Rf)
 665            and then Is_Same_Value (Prefix (Lf), Prefix (Rf))
 666          then
 667             return True;
 668
 669          --  True if the same unary operator applied to the same operand
 670
 671          elsif Nkind (Lf) in N_Unary_Op
 672            and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
 673          then
 674             return True;
 675
 676          --  True if the same binary operator applied to the same operands
 677
 678          elsif Nkind (Lf) in N_Binary_Op
 679            and then Is_Same_Value (Left_Opnd  (Lf), Left_Opnd  (Rf))
 680            and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
 681          then
 682             return True;
 683
 684          --  All other cases, we can't tell, so return False
 685
 686          else
 687             return False;
 688          end if;
 689       end Is_Same_Value;
 690
 691    --  Start of processing for Compile_Time_Compare
 692
 693    begin
 694       Diff.all := No_Uint;
 695
 696       --  If either operand could raise constraint error, then we cannot
 697       --  know the result at compile time (since CE may be raised!)
 698
 699       if not (Cannot_Raise_Constraint_Error (L)
 700                 and then
 701               Cannot_Raise_Constraint_Error (R))
 702       then
 703          return Unknown;
 704       end if;
 705
 706       --  Identical operands are most certainly equal
 707
 708       if L = R then
 709          return EQ;
 710
 711       --  If expressions have no types, then do not attempt to determine if
 712       --  they are the same, since something funny is going on. One case in
 713       --  which this happens is during generic template analysis, when bounds
 714       --  are not fully analyzed.
 715
 716       elsif No (Ltyp) or else No (Rtyp) then
 717          return Unknown;
 718
 719       --  We do not attempt comparisons for packed arrays arrays represented as
 720       --  modular types, where the semantics of comparison is quite different.
 721
 722       elsif Is_Packed_Array_Type (Ltyp)
 723         and then Is_Modular_Integer_Type (Ltyp)
 724       then
 725          return Unknown;
 726
 727       --  For access types, the only time we know the result at compile time
 728       --  (apart from identical operands, which we handled already) is if we
 729       --  know one operand is null and the other is not, or both operands are
 730       --  known null.
 731
 732       elsif Is_Access_Type (Ltyp) then
 733          if Known_Null (L) then
 734             if Known_Null (R) then
 735                return EQ;
 736             elsif Known_Non_Null (R) then
 737                return NE;
 738             else
 739                return Unknown;
 740             end if;
 741
 742          elsif Known_Non_Null (L) and then Known_Null (R) then
 743             return NE;
 744
 745          else
 746             return Unknown;
 747          end if;
 748
 749       --  Case where comparison involves two compile time known values
 750
 751       elsif Compile_Time_Known_Value (L)
 752         and then Compile_Time_Known_Value (R)
 753       then
 754          --  For the floating-point case, we have to be a little careful, since
 755          --  at compile time we are dealing with universal exact values, but at
 756          --  runtime, these will be in non-exact target form. That's why the
 757          --  returned results are LE and GE below instead of LT and GT.
 758
 759          if Is_Floating_Point_Type (Ltyp)
 760               or else
 761             Is_Floating_Point_Type (Rtyp)
 762          then
 763             declare
 764                Lo : constant Ureal := Expr_Value_R (L);
 765                Hi : constant Ureal := Expr_Value_R (R);
 766
 767             begin
 768                if Lo < Hi then
 769                   return LE;
 770                elsif Lo = Hi then
 771                   return EQ;
 772                else
 773                   return GE;
 774                end if;
 775             end;
 776
 777          --  For string types, we have two string literals and we proceed to
 778          --  compare them using the Ada style dictionary string comparison.
 779
 780          elsif not Is_Scalar_Type (Ltyp) then
 781             declare
 782                Lstring : constant String_Id := Strval (Expr_Value_S (L));
 783                Rstring : constant String_Id := Strval (Expr_Value_S (R));
 784                Llen    : constant Nat       := String_Length (Lstring);
 785                Rlen    : constant Nat       := String_Length (Rstring);
 786
 787             begin
 788                for J in 1 .. Nat'Min (Llen, Rlen) loop
 789                   declare
 790                      LC : constant Char_Code := Get_String_Char (Lstring, J);
 791                      RC : constant Char_Code := Get_String_Char (Rstring, J);
 792                   begin
 793                      if LC < RC then
 794                         return LT;
 795                      elsif LC > RC then
 796                         return GT;
 797                      end if;
 798                   end;
 799                end loop;
 800
 801                if Llen < Rlen then
 802                   return LT;
 803                elsif Llen > Rlen then
 804                   return GT;
 805                else
 806                   return EQ;
 807                end if;
 808             end;
 809
 810          --  For remaining scalar cases we know exactly (note that this does
 811          --  include the fixed-point case, where we know the run time integer
 812          --  values now).
 813
 814          else
 815             declare
 816                Lo : constant Uint := Expr_Value (L);
 817                Hi : constant Uint := Expr_Value (R);
 818
 819             begin
 820                if Lo < Hi then
 821                   Diff.all := Hi - Lo;
 822                   return LT;
 823
 824                elsif Lo = Hi then
 825                   return EQ;
 826
 827                else
 828                   Diff.all := Lo - Hi;
 829                   return GT;
 830                end if;
 831             end;
 832          end if;
 833
 834       --  Cases where at least one operand is not known at compile time
 835
 836       else
 837          --  Remaining checks apply only for discrete types
 838
 839          if not Is_Discrete_Type (Ltyp)
 840            or else not Is_Discrete_Type (Rtyp)
 841          then
 842             return Unknown;
 843          end if;
 844
 845          --  Defend against generic types, or actually any expressions that
 846          --  contain a reference to a generic type from within a generic
 847          --  template. We don't want to do any range analysis of such
 848          --  expressions for two reasons. First, the bounds of a generic type
 849          --  itself are junk and cannot be used for any kind of analysis.
 850          --  Second, we may have a case where the range at run time is indeed
 851          --  known, but we don't want to do compile time analysis in the
 852          --  template based on that range since in an instance the value may be
 853          --  static, and able to be elaborated without reference to the bounds
 854          --  of types involved. As an example, consider:
 855
 856          --     (F'Pos (F'Last) + 1) > Integer'Last
 857
 858          --  The expression on the left side of > is Universal_Integer and thus
 859          --  acquires the type Integer for evaluation at run time, and at run
 860          --  time it is true that this condition is always False, but within
 861          --  an instance F may be a type with a static range greater than the
 862          --  range of Integer, and the expression statically evaluates to True.
 863
 864          if References_Generic_Formal_Type (L)
 865               or else
 866             References_Generic_Formal_Type (R)
 867          then
 868             return Unknown;
 869          end if;
 870
 871          --  Replace types by base types for the case of entities which are
 872          --  not known to have valid representations. This takes care of
 873          --  properly dealing with invalid representations.
 874
 875          if not Assume_Valid and then not Assume_No_Invalid_Values then
 876             if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then
 877                Ltyp := Underlying_Type (Base_Type (Ltyp));
 878             end if;
 879
 880             if Is_Entity_Name (R) and then not Is_Known_Valid (Entity (R)) then
 881                Rtyp := Underlying_Type (Base_Type (Rtyp));
 882             end if;
 883          end if;
 884
 885          --  Try range analysis on variables and see if ranges are disjoint
 886
 887          declare
 888             LOK, ROK : Boolean;
 889             LLo, LHi : Uint;
 890             RLo, RHi : Uint;
 891
 892          begin
 893             Determine_Range (L, LOK, LLo, LHi, Assume_Valid);
 894             Determine_Range (R, ROK, RLo, RHi, Assume_Valid);
 895
 896             if LOK and ROK then
 897                if LHi < RLo then
 898                   return LT;
 899
 900                elsif RHi < LLo then
 901                   return GT;
 902
 903                elsif LLo = LHi
 904                  and then RLo = RHi
 905                  and then LLo = RLo
 906                then
 907
 908                   --  If the range includes a single literal and we can assume
 909                   --  validity then the result is known even if an operand is
 910                   --  not static.
 911
 912                   if Assume_Valid then
 913                      return EQ;
 914                   else
 915                      return Unknown;
 916                   end if;
 917
 918                elsif LHi = RLo then
 919                   return LE;
 920
 921                elsif RHi = LLo then
 922                   return GE;
 923
 924                elsif not Is_Known_Valid_Operand (L)
 925                  and then not Assume_Valid
 926                then
 927                   if Is_Same_Value (L, R) then
 928                      return EQ;
 929                   else
 930                      return Unknown;
 931                   end if;
 932                end if;
 933             end if;
 934          end;
 935
 936          --  Here is where we check for comparisons against maximum bounds of
 937          --  types, where we know that no value can be outside the bounds of
 938          --  the subtype. Note that this routine is allowed to assume that all
 939          --  expressions are within their subtype bounds. Callers wishing to
 940          --  deal with possibly invalid values must in any case take special
 941          --  steps (e.g. conversions to larger types) to avoid this kind of
 942          --  optimization, which is always considered to be valid. We do not
 943          --  attempt this optimization with generic types, since the type
 944          --  bounds may not be meaningful in this case.
 945
 946          --  We are in danger of an infinite recursion here. It does not seem
 947          --  useful to go more than one level deep, so the parameter Rec is
 948          --  used to protect ourselves against this infinite recursion.
 949
 950          if not Rec then
 951
 952             --  See if we can get a decisive check against one operand and
 953             --  a bound of the other operand (four possible tests here).
 954             --  Note that we avoid testing junk bounds of a generic type.
 955
 956             if not Is_Generic_Type (Rtyp) then
 957                case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
 958                                           Discard'Access,
 959                                           Assume_Valid, Rec => True)
 960                is
 961                   when LT => return LT;
 962                   when LE => return LE;
 963                   when EQ => return LE;
 964                   when others => null;
 965                end case;
 966
 967                case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
 968                                           Discard'Access,
 969                                           Assume_Valid, Rec => True)
 970                is
 971                   when GT => return GT;
 972                   when GE => return GE;
 973                   when EQ => return GE;
 974                   when others => null;
 975                end case;
 976             end if;
 977
 978             if not Is_Generic_Type (Ltyp) then
 979                case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
 980                                           Discard'Access,
 981                                           Assume_Valid, Rec => True)
 982                is
 983                   when GT => return GT;
 984                   when GE => return GE;
 985                   when EQ => return GE;
 986                   when others => null;
 987                end case;
 988
 989                case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
 990                                           Discard'Access,
 991                                           Assume_Valid, Rec => True)
 992                is
 993                   when LT => return LT;
 994                   when LE => return LE;
 995                   when EQ => return LE;
 996                   when others => null;
 997                end case;
 998             end if;
 999          end if;
1000
1001          --  Next attempt is to decompose the expressions to extract
1002          --  a constant offset resulting from the use of any of the forms:
1003
1004          --     expr + literal
1005          --     expr - literal
1006          --     typ'Succ (expr)
1007          --     typ'Pred (expr)
1008
1009          --  Then we see if the two expressions are the same value, and if so
1010          --  the result is obtained by comparing the offsets.
1011
1012          declare
1013             Lnode : Node_Id;
1014             Loffs : Uint;
1015             Rnode : Node_Id;
1016             Roffs : Uint;
1017
1018          begin
1019             Compare_Decompose (L, Lnode, Loffs);
1020             Compare_Decompose (R, Rnode, Roffs);
1021
1022             if Is_Same_Value (Lnode, Rnode) then
1023                if Loffs = Roffs then
1024                   return EQ;
1025
1026                elsif Loffs < Roffs then
1027                   Diff.all := Roffs - Loffs;
1028                   return LT;
1029
1030                else
1031                   Diff.all := Loffs - Roffs;
1032                   return GT;
1033                end if;
1034             end if;
1035          end;
1036
1037          --  Next attempt is to see if we have an entity compared with a
1038          --  compile time known value, where there is a current value
1039          --  conditional for the entity which can tell us the result.
1040
1041          declare
1042             Var : Node_Id;
1043             --  Entity variable (left operand)
1044
1045             Val : Uint;
1046             --  Value (right operand)
1047
1048             Inv : Boolean;
1049             --  If False, we have reversed the operands
1050
1051             Op : Node_Kind;
1052             --  Comparison operator kind from Get_Current_Value_Condition call
1053
1054             Opn : Node_Id;
1055             --  Value from Get_Current_Value_Condition call
1056
1057             Opv : Uint;
1058             --  Value of Opn
1059
1060             Result : Compare_Result;
1061             --  Known result before inversion
1062
1063          begin
1064             if Is_Entity_Name (L)
1065               and then Compile_Time_Known_Value (R)
1066             then
1067                Var := L;
1068                Val := Expr_Value (R);
1069                Inv := False;
1070
1071             elsif Is_Entity_Name (R)
1072               and then Compile_Time_Known_Value (L)
1073             then
1074                Var := R;
1075                Val := Expr_Value (L);
1076                Inv := True;
1077
1078                --  That was the last chance at finding a compile time result
1079
1080             else
1081                return Unknown;
1082             end if;
1083
1084             Get_Current_Value_Condition (Var, Op, Opn);
1085
1086             --  That was the last chance, so if we got nothing return
1087
1088             if No (Opn) then
1089                return Unknown;
1090             end if;
1091
1092             Opv := Expr_Value (Opn);
1093
1094             --  We got a comparison, so we might have something interesting
1095
1096             --  Convert LE to LT and GE to GT, just so we have fewer cases
1097
1098             if Op = N_Op_Le then
1099                Op := N_Op_Lt;
1100                Opv := Opv + 1;
1101
1102             elsif Op = N_Op_Ge then
1103                Op := N_Op_Gt;
1104                Opv := Opv - 1;
1105             end if;
1106
1107             --  Deal with equality case
1108
1109             if Op = N_Op_Eq then
1110                if Val = Opv then
1111                   Result := EQ;
1112                elsif Opv < Val then
1113                   Result := LT;
1114                else
1115                   Result := GT;
1116                end if;
1117
1118             --  Deal with inequality case
1119
1120             elsif Op = N_Op_Ne then
1121                if Val = Opv then
1122                   Result := NE;
1123                else
1124                   return Unknown;
1125                end if;
1126
1127             --  Deal with greater than case
1128
1129             elsif Op = N_Op_Gt then
1130                if Opv >= Val then
1131                   Result := GT;
1132                elsif Opv = Val - 1 then
1133                   Result := GE;
1134                else
1135                   return Unknown;
1136                end if;
1137
1138             --  Deal with less than case
1139
1140             else pragma Assert (Op = N_Op_Lt);
1141                if Opv <= Val then
1142                   Result := LT;
1143                elsif Opv = Val + 1 then
1144                   Result := LE;
1145                else
1146                   return Unknown;
1147                end if;
1148             end if;
1149
1150             --  Deal with inverting result
1151
1152             if Inv then
1153                case Result is
1154                   when GT     => return LT;
1155                   when GE     => return LE;
1156                   when LT     => return GT;
1157                   when LE     => return GE;
1158                   when others => return Result;
1159                end case;
1160             end if;
1161
1162             return Result;
1163          end;
1164       end if;
1165    end Compile_Time_Compare;
1166
1167    -------------------------------
1168    -- Compile_Time_Known_Bounds --
1169    -------------------------------
1170
1171    function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is
1172       Indx : Node_Id;
1173       Typ  : Entity_Id;
1174
1175    begin
1176       if not Is_Array_Type (T) then
1177          return False;
1178       end if;
1179
1180       Indx := First_Index (T);
1181       while Present (Indx) loop
1182          Typ := Underlying_Type (Etype (Indx));
1183
1184          --  Never look at junk bounds of a generic type
1185
1186          if Is_Generic_Type (Typ) then
1187             return False;
1188          end if;
1189
1190          --  Otherwise check bounds for compile time known
1191
1192          if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
1193             return False;
1194          elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then
1195             return False;
1196          else
1197             Next_Index (Indx);
1198          end if;
1199       end loop;
1200
1201       return True;
1202    end Compile_Time_Known_Bounds;
1203
1204    ------------------------------
1205    -- Compile_Time_Known_Value --
1206    ------------------------------
1207
1208    function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1209       K      : constant Node_Kind := Nkind (Op);
1210       CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
1211
1212    begin
1213       --  Never known at compile time if bad type or raises constraint error
1214       --  or empty (latter case occurs only as a result of a previous error)
1215
1216       if No (Op)
1217         or else Op = Error
1218         or else Etype (Op) = Any_Type
1219         or else Raises_Constraint_Error (Op)
1220       then
1221          return False;
1222       end if;
1223
1224       --  If this is not a static expression or a null literal, and we are in
1225       --  configurable run-time mode, then we consider it not known at compile
1226       --  time. This avoids anomalies where whether something is allowed with a
1227       --  given configurable run-time library depends on how good the compiler
1228       --  is at optimizing and knowing that things are constant when they are
1229       --  nonstatic.
1230
1231       if Configurable_Run_Time_Mode
1232         and then K /= N_Null
1233         and then not Is_Static_Expression (Op)
1234       then
1235          return False;
1236       end if;
1237
1238       --  If we have an entity name, then see if it is the name of a constant
1239       --  and if so, test the corresponding constant value, or the name of
1240       --  an enumeration literal, which is always a constant.
1241
1242       if Present (Etype (Op)) and then Is_Entity_Name (Op) then
1243          declare
1244             E : constant Entity_Id := Entity (Op);
1245             V : Node_Id;
1246
1247          begin
1248             --  Never known at compile time if it is a packed array value.
1249             --  We might want to try to evaluate these at compile time one
1250             --  day, but we do not make that attempt now.
1251
1252             if Is_Packed_Array_Type (Etype (Op)) then
1253                return False;
1254             end if;
1255
1256             if Ekind (E) = E_Enumeration_Literal then
1257                return True;
1258
1259             elsif Ekind (E) = E_Constant then
1260                V := Constant_Value (E);
1261                return Present (V) and then Compile_Time_Known_Value (V);
1262             end if;
1263          end;
1264
1265       --  We have a value, see if it is compile time known
1266
1267       else
1268          --  Integer literals are worth storing in the cache
1269
1270          if K = N_Integer_Literal then
1271             CV_Ent.N := Op;
1272             CV_Ent.V := Intval (Op);
1273             return True;
1274
1275          --  Other literals and NULL are known at compile time
1276
1277          elsif
1278             K = N_Character_Literal
1279               or else
1280             K = N_Real_Literal
1281               or else
1282             K = N_String_Literal
1283               or else
1284             K = N_Null
1285          then
1286             return True;
1287
1288          --  Any reference to Null_Parameter is known at compile time. No
1289          --  other attribute references (that have not already been folded)
1290          --  are known at compile time.
1291
1292          elsif K = N_Attribute_Reference then
1293             return Attribute_Name (Op) = Name_Null_Parameter;
1294          end if;
1295       end if;
1296
1297       --  If we fall through, not known at compile time
1298
1299       return False;
1300
1301    --  If we get an exception while trying to do this test, then some error
1302    --  has occurred, and we simply say that the value is not known after all
1303
1304    exception
1305       when others =>
1306          return False;
1307    end Compile_Time_Known_Value;
1308
1309    --------------------------------------
1310    -- Compile_Time_Known_Value_Or_Aggr --
1311    --------------------------------------
1312
1313    function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
1314    begin
1315       --  If we have an entity name, then see if it is the name of a constant
1316       --  and if so, test the corresponding constant value, or the name of
1317       --  an enumeration literal, which is always a constant.
1318
1319       if Is_Entity_Name (Op) then
1320          declare
1321             E : constant Entity_Id := Entity (Op);
1322             V : Node_Id;
1323
1324          begin
1325             if Ekind (E) = E_Enumeration_Literal then
1326                return True;
1327
1328             elsif Ekind (E) /= E_Constant then
1329                return False;
1330
1331             else
1332                V := Constant_Value (E);
1333                return Present (V)
1334                  and then Compile_Time_Known_Value_Or_Aggr (V);
1335             end if;
1336          end;
1337
1338       --  We have a value, see if it is compile time known
1339
1340       else
1341          if Compile_Time_Known_Value (Op) then
1342             return True;
1343
1344          elsif Nkind (Op) = N_Aggregate then
1345
1346             if Present (Expressions (Op)) then
1347                declare
1348                   Expr : Node_Id;
1349
1350                begin
1351                   Expr := First (Expressions (Op));
1352                   while Present (Expr) loop
1353                      if not Compile_Time_Known_Value_Or_Aggr (Expr) then
1354                         return False;
1355                      end if;
1356
1357                      Next (Expr);
1358                   end loop;
1359                end;
1360             end if;
1361
1362             if Present (Component_Associations (Op)) then
1363                declare
1364                   Cass : Node_Id;
1365
1366                begin
1367                   Cass := First (Component_Associations (Op));
1368                   while Present (Cass) loop
1369                      if not
1370                        Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
1371                      then
1372                         return False;
1373                      end if;
1374
1375                      Next (Cass);
1376                   end loop;
1377                end;
1378             end if;
1379
1380             return True;
1381
1382          --  All other types of values are not known at compile time
1383
1384          else
1385             return False;
1386          end if;
1387
1388       end if;
1389    end Compile_Time_Known_Value_Or_Aggr;
1390
1391    -----------------
1392    -- Eval_Actual --
1393    -----------------
1394
1395    --  This is only called for actuals of functions that are not predefined
1396    --  operators (which have already been rewritten as operators at this
1397    --  stage), so the call can never be folded, and all that needs doing for
1398    --  the actual is to do the check for a non-static context.
1399
1400    procedure Eval_Actual (N : Node_Id) is
1401    begin
1402       Check_Non_Static_Context (N);
1403    end Eval_Actual;
1404
1405    --------------------
1406    -- Eval_Allocator --
1407    --------------------
1408
1409    --  Allocators are never static, so all we have to do is to do the
1410    --  check for a non-static context if an expression is present.
1411
1412    procedure Eval_Allocator (N : Node_Id) is
1413       Expr : constant Node_Id := Expression (N);
1414
1415    begin
1416       if Nkind (Expr) = N_Qualified_Expression then
1417          Check_Non_Static_Context (Expression (Expr));
1418       end if;
1419    end Eval_Allocator;
1420
1421    ------------------------
1422    -- Eval_Arithmetic_Op --
1423    ------------------------
1424
1425    --  Arithmetic operations are static functions, so the result is static
1426    --  if both operands are static (RM 4.9(7), 4.9(20)).
1427
1428    procedure Eval_Arithmetic_Op (N : Node_Id) is
1429       Left  : constant Node_Id   := Left_Opnd (N);
1430       Right : constant Node_Id   := Right_Opnd (N);
1431       Ltype : constant Entity_Id := Etype (Left);
1432       Rtype : constant Entity_Id := Etype (Right);
1433       Stat  : Boolean;
1434       Fold  : Boolean;
1435
1436    begin
1437       --  If not foldable we are done
1438
1439       Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1440
1441       if not Fold then
1442          return;
1443       end if;
1444
1445       --  Fold for cases where both operands are of integer type
1446
1447       if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
1448          declare
1449             Left_Int  : constant Uint := Expr_Value (Left);
1450             Right_Int : constant Uint := Expr_Value (Right);
1451             Result    : Uint;
1452
1453          begin
1454             case Nkind (N) is
1455
1456                when N_Op_Add =>
1457                   Result := Left_Int + Right_Int;
1458
1459                when N_Op_Subtract =>
1460                   Result := Left_Int - Right_Int;
1461
1462                when N_Op_Multiply =>
1463                   if OK_Bits
1464                        (N, UI_From_Int
1465                              (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
1466                   then
1467                      Result := Left_Int * Right_Int;
1468                   else
1469                      Result := Left_Int;
1470                   end if;
1471
1472                when N_Op_Divide =>
1473
1474                   --  The exception Constraint_Error is raised by integer
1475                   --  division, rem and mod if the right operand is zero.
1476
1477                   if Right_Int = 0 then
1478                      Apply_Compile_Time_Constraint_Error
1479                        (N, "division by zero",
1480                         CE_Divide_By_Zero,
1481                         Warn => not Stat);
1482                      return;
1483
1484                   else
1485                      Result := Left_Int / Right_Int;
1486                   end if;
1487
1488                when N_Op_Mod =>
1489
1490                   --  The exception Constraint_Error is raised by integer
1491                   --  division, rem and mod if the right operand is zero.
1492
1493                   if Right_Int = 0 then
1494                      Apply_Compile_Time_Constraint_Error
1495                        (N, "mod with zero divisor",
1496                         CE_Divide_By_Zero,
1497                         Warn => not Stat);
1498                      return;
1499                   else
1500                      Result := Left_Int mod Right_Int;
1501                   end if;
1502
1503                when N_Op_Rem =>
1504
1505                   --  The exception Constraint_Error is raised by integer
1506                   --  division, rem and mod if the right operand is zero.
1507
1508                   if Right_Int = 0 then
1509                      Apply_Compile_Time_Constraint_Error
1510                        (N, "rem with zero divisor",
1511                         CE_Divide_By_Zero,
1512                         Warn => not Stat);
1513                      return;
1514
1515                   else
1516                      Result := Left_Int rem Right_Int;
1517                   end if;
1518
1519                when others =>
1520                   raise Program_Error;
1521             end case;
1522
1523             --  Adjust the result by the modulus if the type is a modular type
1524
1525             if Is_Modular_Integer_Type (Ltype) then
1526                Result := Result mod Modulus (Ltype);
1527
1528                --  For a signed integer type, check non-static overflow
1529
1530             elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then
1531                declare
1532                   BT : constant Entity_Id := Base_Type (Ltype);
1533                   Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
1534                   Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
1535                begin
1536                   if Result < Lo or else Result > Hi then
1537                      Apply_Compile_Time_Constraint_Error
1538                        (N, "value not in range of }?",
1539                         CE_Overflow_Check_Failed,
1540                         Ent => BT);
1541                      return;
1542                   end if;
1543                end;
1544             end if;
1545
1546             --  If we get here we can fold the result
1547
1548             Fold_Uint (N, Result, Stat);
1549          end;
1550
1551       --  Cases where at least one operand is a real. We handle the cases
1552       --  of both reals, or mixed/real integer cases (the latter happen
1553       --  only for divide and multiply, and the result is always real).
1554
1555       elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
1556          declare
1557             Left_Real  : Ureal;
1558             Right_Real : Ureal;
1559             Result     : Ureal;
1560
1561          begin
1562             if Is_Real_Type (Ltype) then
1563                Left_Real := Expr_Value_R (Left);
1564             else
1565                Left_Real := UR_From_Uint (Expr_Value (Left));
1566             end if;
1567
1568             if Is_Real_Type (Rtype) then
1569                Right_Real := Expr_Value_R (Right);
1570             else
1571                Right_Real := UR_From_Uint (Expr_Value (Right));
1572             end if;
1573
1574             if Nkind (N) = N_Op_Add then
1575                Result := Left_Real + Right_Real;
1576
1577             elsif Nkind (N) = N_Op_Subtract then
1578                Result := Left_Real - Right_Real;
1579
1580             elsif Nkind (N) = N_Op_Multiply then
1581                Result := Left_Real * Right_Real;
1582
1583             else pragma Assert (Nkind (N) = N_Op_Divide);
1584                if UR_Is_Zero (Right_Real) then
1585                   Apply_Compile_Time_Constraint_Error
1586                     (N, "division by zero", CE_Divide_By_Zero);
1587                   return;
1588                end if;
1589
1590                Result := Left_Real / Right_Real;
1591             end if;
1592
1593             Fold_Ureal (N, Result, Stat);
1594          end;
1595       end if;
1596    end Eval_Arithmetic_Op;
1597
1598    ----------------------------
1599    -- Eval_Character_Literal --
1600    ----------------------------
1601
1602    --  Nothing to be done!
1603
1604    procedure Eval_Character_Literal (N : Node_Id) is
1605       pragma Warnings (Off, N);
1606    begin
1607       null;
1608    end Eval_Character_Literal;
1609
1610    ---------------
1611    -- Eval_Call --
1612    ---------------
1613
1614    --  Static function calls are either calls to predefined operators
1615    --  with static arguments, or calls to functions that rename a literal.
1616    --  Only the latter case is handled here, predefined operators are
1617    --  constant-folded elsewhere.
1618
1619    --  If the function is itself inherited (see 7423-001) the literal of
1620    --  the parent type must be explicitly converted to the return type
1621    --  of the function.
1622
1623    procedure Eval_Call (N : Node_Id) is
1624       Loc : constant Source_Ptr := Sloc (N);
1625       Typ : constant Entity_Id  := Etype (N);
1626       Lit : Entity_Id;
1627
1628    begin
1629       if Nkind (N) = N_Function_Call
1630         and then No (Parameter_Associations (N))
1631         and then Is_Entity_Name (Name (N))
1632         and then Present (Alias (Entity (Name (N))))
1633         and then Is_Enumeration_Type (Base_Type (Typ))
1634       then
1635          Lit := Alias (Entity (Name (N)));
1636          while Present (Alias (Lit)) loop
1637             Lit := Alias (Lit);
1638          end loop;
1639
1640          if Ekind (Lit) = E_Enumeration_Literal then
1641             if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
1642                Rewrite
1643                  (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
1644             else
1645                Rewrite (N, New_Occurrence_Of (Lit, Loc));
1646             end if;
1647
1648             Resolve (N, Typ);
1649          end if;
1650       end if;
1651    end Eval_Call;
1652
1653    ------------------------
1654    -- Eval_Concatenation --
1655    ------------------------
1656
1657    --  Concatenation is a static function, so the result is static if both
1658    --  operands are static (RM 4.9(7), 4.9(21)).
1659
1660    procedure Eval_Concatenation (N : Node_Id) is
1661       Left  : constant Node_Id   := Left_Opnd (N);
1662       Right : constant Node_Id   := Right_Opnd (N);
1663       C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
1664       Stat  : Boolean;
1665       Fold  : Boolean;
1666
1667    begin
1668       --  Concatenation is never static in Ada 83, so if Ada 83 check operand
1669       --  non-static context.
1670
1671       if Ada_Version = Ada_83
1672         and then Comes_From_Source (N)
1673       then
1674          Check_Non_Static_Context (Left);
1675          Check_Non_Static_Context (Right);
1676          return;
1677       end if;
1678
1679       --  If not foldable we are done. In principle concatenation that yields
1680       --  any string type is static (i.e. an array type of character types).
1681       --  However, character types can include enumeration literals, and
1682       --  concatenation in that case cannot be described by a literal, so we
1683       --  only consider the operation static if the result is an array of
1684       --  (a descendant of) a predefined character type.
1685
1686       Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1687
1688       if not (Is_Standard_Character_Type (C_Typ) and then Fold) then
1689          Set_Is_Static_Expression (N, False);
1690          return;
1691       end if;
1692
1693       --  Compile time string concatenation
1694
1695       --  ??? Note that operands that are aggregates can be marked as static,
1696       --  so we should attempt at a later stage to fold concatenations with
1697       --  such aggregates.
1698
1699       declare
1700          Left_Str   : constant Node_Id := Get_String_Val (Left);
1701          Left_Len   : Nat;
1702          Right_Str  : constant Node_Id := Get_String_Val (Right);
1703          Folded_Val : String_Id;
1704
1705       begin
1706          --  Establish new string literal, and store left operand. We make
1707          --  sure to use the special Start_String that takes an operand if
1708          --  the left operand is a string literal. Since this is optimized
1709          --  in the case where that is the most recently created string
1710          --  literal, we ensure efficient time/space behavior for the
1711          --  case of a concatenation of a series of string literals.
1712
1713          if Nkind (Left_Str) = N_String_Literal then
1714             Left_Len :=  String_Length (Strval (Left_Str));
1715
1716             --  If the left operand is the empty string, and the right operand
1717             --  is a string literal (the case of "" & "..."), the result is the
1718             --  value of the right operand. This optimization is important when
1719             --  Is_Folded_In_Parser, to avoid copying an enormous right
1720             --  operand.
1721
1722             if Left_Len = 0 and then Nkind (Right_Str) = N_String_Literal then
1723                Folded_Val := Strval (Right_Str);
1724             else
1725                Start_String (Strval (Left_Str));
1726             end if;
1727
1728          else
1729             Start_String;
1730             Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str)));
1731             Left_Len := 1;
1732          end if;
1733
1734          --  Now append the characters of the right operand, unless we
1735          --  optimized the "" & "..." case above.
1736
1737          if Nkind (Right_Str) = N_String_Literal then
1738             if Left_Len /= 0 then
1739                Store_String_Chars (Strval (Right_Str));
1740                Folded_Val := End_String;
1741             end if;
1742          else
1743             Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str)));
1744             Folded_Val := End_String;
1745          end if;
1746
1747          Set_Is_Static_Expression (N, Stat);
1748
1749          if Stat then
1750
1751             --  If left operand is the empty string, the result is the
1752             --  right operand, including its bounds if anomalous.
1753
1754             if Left_Len = 0
1755               and then Is_Array_Type (Etype (Right))
1756               and then Etype (Right) /= Any_String
1757             then
1758                Set_Etype (N, Etype (Right));
1759             end if;
1760
1761             Fold_Str (N, Folded_Val, Static => True);
1762          end if;
1763       end;
1764    end Eval_Concatenation;
1765
1766    ---------------------------------
1767    -- Eval_Conditional_Expression --
1768    ---------------------------------
1769
1770    --  This GNAT internal construct can never be statically folded, so the
1771    --  only required processing is to do the check for non-static context
1772    --  for the two expression operands.
1773
1774    procedure Eval_Conditional_Expression (N : Node_Id) is
1775       Condition : constant Node_Id := First (Expressions (N));
1776       Then_Expr : constant Node_Id := Next (Condition);
1777       Else_Expr : constant Node_Id := Next (Then_Expr);
1778
1779    begin
1780       Check_Non_Static_Context (Then_Expr);
1781       Check_Non_Static_Context (Else_Expr);
1782    end Eval_Conditional_Expression;
1783
1784    ----------------------
1785    -- Eval_Entity_Name --
1786    ----------------------
1787
1788    --  This procedure is used for identifiers and expanded names other than
1789    --  named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
1790    --  static if they denote a static constant (RM 4.9(6)) or if the name
1791    --  denotes an enumeration literal (RM 4.9(22)).
1792
1793    procedure Eval_Entity_Name (N : Node_Id) is
1794       Def_Id : constant Entity_Id := Entity (N);
1795       Val    : Node_Id;
1796
1797    begin
1798       --  Enumeration literals are always considered to be constants
1799       --  and cannot raise constraint error (RM 4.9(22)).
1800
1801       if Ekind (Def_Id) = E_Enumeration_Literal then
1802          Set_Is_Static_Expression (N);
1803          return;
1804
1805       --  A name is static if it denotes a static constant (RM 4.9(5)), and
1806       --  we also copy Raise_Constraint_Error. Notice that even if non-static,
1807       --  it does not violate 10.2.1(8) here, since this is not a variable.
1808
1809       elsif Ekind (Def_Id) = E_Constant then
1810
1811          --  Deferred constants must always be treated as nonstatic
1812          --  outside the scope of their full view.
1813
1814          if Present (Full_View (Def_Id))
1815            and then not In_Open_Scopes (Scope (Def_Id))
1816          then
1817             Val := Empty;
1818          else
1819             Val := Constant_Value (Def_Id);
1820          end if;
1821
1822          if Present (Val) then
1823             Set_Is_Static_Expression
1824               (N, Is_Static_Expression (Val)
1825                     and then Is_Static_Subtype (Etype (Def_Id)));
1826             Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
1827
1828             if not Is_Static_Expression (N)
1829               and then not Is_Generic_Type (Etype (N))
1830             then
1831                Validate_Static_Object_Name (N);
1832             end if;
1833
1834             return;
1835          end if;
1836       end if;
1837
1838       --  Fall through if the name is not static
1839
1840       Validate_Static_Object_Name (N);
1841    end Eval_Entity_Name;
1842
1843    ----------------------------
1844    -- Eval_Indexed_Component --
1845    ----------------------------
1846
1847    --  Indexed components are never static, so we need to perform the check
1848    --  for non-static context on the index values. Then, we check if the
1849    --  value can be obtained at compile time, even though it is non-static.
1850
1851    procedure Eval_Indexed_Component (N : Node_Id) is
1852       Expr : Node_Id;
1853
1854    begin
1855       --  Check for non-static context on index values
1856
1857       Expr := First (Expressions (N));
1858       while Present (Expr) loop
1859          Check_Non_Static_Context (Expr);
1860          Next (Expr);
1861       end loop;
1862
1863       --  If the indexed component appears in an object renaming declaration
1864       --  then we do not want to try to evaluate it, since in this case we
1865       --  need the identity of the array element.
1866
1867       if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
1868          return;
1869
1870       --  Similarly if the indexed component appears as the prefix of an
1871       --  attribute we don't want to evaluate it, because at least for
1872       --  some cases of attributes we need the identify (e.g. Access, Size)
1873
1874       elsif Nkind (Parent (N)) = N_Attribute_Reference then
1875          return;
1876       end if;
1877
1878       --  Note: there are other cases, such as the left side of an assignment,
1879       --  or an OUT parameter for a call, where the replacement results in the
1880       --  illegal use of a constant, But these cases are illegal in the first
1881       --  place, so the replacement, though silly, is harmless.
1882
1883       --  Now see if this is a constant array reference
1884
1885       if List_Length (Expressions (N)) = 1
1886         and then Is_Entity_Name (Prefix (N))
1887         and then Ekind (Entity (Prefix (N))) = E_Constant
1888         and then Present (Constant_Value (Entity (Prefix (N))))
1889       then
1890          declare
1891             Loc : constant Source_Ptr := Sloc (N);
1892             Arr : constant Node_Id    := Constant_Value (Entity (Prefix (N)));
1893             Sub : constant Node_Id    := First (Expressions (N));
1894
1895             Atyp : Entity_Id;
1896             --  Type of array
1897
1898             Lin : Nat;
1899             --  Linear one's origin subscript value for array reference
1900
1901             Lbd : Node_Id;
1902             --  Lower bound of the first array index
1903
1904             Elm : Node_Id;
1905             --  Value from constant array
1906
1907          begin
1908             Atyp := Etype (Arr);
1909
1910             if Is_Access_Type (Atyp) then
1911                Atyp := Designated_Type (Atyp);
1912             end if;
1913
1914             --  If we have an array type (we should have but perhaps there
1915             --  are error cases where this is not the case), then see if we
1916             --  can do a constant evaluation of the array reference.
1917
1918             if Is_Array_Type (Atyp) then
1919                if Ekind (Atyp) = E_String_Literal_Subtype then
1920                   Lbd := String_Literal_Low_Bound (Atyp);
1921                else
1922                   Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
1923                end if;
1924
1925                if Compile_Time_Known_Value (Sub)
1926                  and then Nkind (Arr) = N_Aggregate
1927                  and then Compile_Time_Known_Value (Lbd)
1928                  and then Is_Discrete_Type (Component_Type (Atyp))
1929                then
1930                   Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
1931
1932                   if List_Length (Expressions (Arr)) >= Lin then
1933                      Elm := Pick (Expressions (Arr), Lin);
1934
1935                      --  If the resulting expression is compile time known,
1936                      --  then we can rewrite the indexed component with this
1937                      --  value, being sure to mark the result as non-static.
1938                      --  We also reset the Sloc, in case this generates an
1939                      --  error later on (e.g. 136'Access).
1940
1941                      if Compile_Time_Known_Value (Elm) then
1942                         Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
1943                         Set_Is_Static_Expression (N, False);
1944                         Set_Sloc (N, Loc);
1945                      end if;
1946                   end if;
1947
1948                --  We can also constant-fold if the prefix is a string literal.
1949                --  This will be useful in an instantiation or an inlining.
1950
1951                elsif Compile_Time_Known_Value (Sub)
1952                  and then Nkind (Arr) = N_String_Literal
1953                  and then Compile_Time_Known_Value (Lbd)
1954                  and then Expr_Value (Lbd) = 1
1955                  and then Expr_Value (Sub) <=
1956                    String_Literal_Length (Etype (Arr))
1957                then
1958                   declare
1959                      C : constant Char_Code :=
1960                            Get_String_Char (Strval (Arr),
1961                              UI_To_Int (Expr_Value (Sub)));
1962                   begin
1963                      Set_Character_Literal_Name (C);
1964
1965                      Elm :=
1966                        Make_Character_Literal (Loc,
1967                          Chars              => Name_Find,
1968                          Char_Literal_Value => UI_From_CC (C));
1969                      Set_Etype (Elm, Component_Type (Atyp));
1970                      Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
1971                      Set_Is_Static_Expression (N, False);
1972                   end;
1973                end if;
1974             end if;
1975          end;
1976       end if;
1977    end Eval_Indexed_Component;
1978
1979    --------------------------
1980    -- Eval_Integer_Literal --
1981    --------------------------
1982
1983    --  Numeric literals are static (RM 4.9(1)), and have already been marked
1984    --  as static by the analyzer. The reason we did it that early is to allow
1985    --  the possibility of turning off the Is_Static_Expression flag after
1986    --  analysis, but before resolution, when integer literals are generated
1987    --  in the expander that do not correspond to static expressions.
1988
1989    procedure Eval_Integer_Literal (N : Node_Id) is
1990       T : constant Entity_Id := Etype (N);
1991
1992       function In_Any_Integer_Context return Boolean;
1993       --  If the literal is resolved with a specific type in a context where
1994       --  the expected type is Any_Integer, there are no range checks on the
1995       --  literal. By the time the literal is evaluated, it carries the type
1996       --  imposed by the enclosing expression, and we must recover the context
1997       --  to determine that Any_Integer is meant.
1998
1999       ----------------------------
2000       -- In_Any_Integer_Context --
2001       ----------------------------
2002
2003       function In_Any_Integer_Context return Boolean is
2004          Par : constant Node_Id   := Parent (N);
2005          K   : constant Node_Kind := Nkind (Par);
2006
2007       begin
2008          --  Any_Integer also appears in digits specifications for real types,
2009          --  but those have bounds smaller that those of any integer base type,
2010          --  so we can safely ignore these cases.
2011
2012          return    K = N_Number_Declaration
2013            or else K = N_Attribute_Reference
2014            or else K = N_Attribute_Definition_Clause
2015            or else K = N_Modular_Type_Definition
2016            or else K = N_Signed_Integer_Type_Definition;
2017       end In_Any_Integer_Context;
2018
2019    --  Start of processing for Eval_Integer_Literal
2020
2021    begin
2022
2023       --  If the literal appears in a non-expression context, then it is
2024       --  certainly appearing in a non-static context, so check it. This is
2025       --  actually a redundant check, since Check_Non_Static_Context would
2026       --  check it, but it seems worth while avoiding the call.
2027
2028       if Nkind (Parent (N)) not in N_Subexpr
2029         and then not In_Any_Integer_Context
2030       then
2031          Check_Non_Static_Context (N);
2032       end if;
2033
2034       --  Modular integer literals must be in their base range
2035
2036       if Is_Modular_Integer_Type (T)
2037         and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
2038       then
2039          Out_Of_Range (N);
2040       end if;
2041    end Eval_Integer_Literal;
2042
2043    ---------------------
2044    -- Eval_Logical_Op --
2045    ---------------------
2046
2047    --  Logical operations are static functions, so the result is potentially
2048    --  static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2049
2050    procedure Eval_Logical_Op (N : Node_Id) is
2051       Left  : constant Node_Id := Left_Opnd (N);
2052       Right : constant Node_Id := Right_Opnd (N);
2053       Stat  : Boolean;
2054       Fold  : Boolean;
2055
2056    begin
2057       --  If not foldable we are done
2058
2059       Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2060
2061       if not Fold then
2062          return;
2063       end if;
2064
2065       --  Compile time evaluation of logical operation
2066
2067       declare
2068          Left_Int  : constant Uint := Expr_Value (Left);
2069          Right_Int : constant Uint := Expr_Value (Right);
2070
2071       begin
2072          if Is_Modular_Integer_Type (Etype (N)) then
2073             declare
2074                Left_Bits  : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2075                Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2076
2077             begin
2078                To_Bits (Left_Int, Left_Bits);
2079                To_Bits (Right_Int, Right_Bits);
2080
2081                --  Note: should really be able to use array ops instead of
2082                --  these loops, but they weren't working at the time ???
2083
2084                if Nkind (N) = N_Op_And then
2085                   for J in Left_Bits'Range loop
2086                      Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
2087                   end loop;
2088
2089                elsif Nkind (N) = N_Op_Or then
2090                   for J in Left_Bits'Range loop
2091                      Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
2092                   end loop;
2093
2094                else
2095                   pragma Assert (Nkind (N) = N_Op_Xor);
2096
2097                   for J in Left_Bits'Range loop
2098                      Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
2099                   end loop;
2100                end if;
2101
2102                Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
2103             end;
2104
2105          else
2106             pragma Assert (Is_Boolean_Type (Etype (N)));
2107
2108             if Nkind (N) = N_Op_And then
2109                Fold_Uint (N,
2110                  Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
2111
2112             elsif Nkind (N) = N_Op_Or then
2113                Fold_Uint (N,
2114                  Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
2115
2116             else
2117                pragma Assert (Nkind (N) = N_Op_Xor);
2118                Fold_Uint (N,
2119                  Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
2120             end if;
2121          end if;
2122       end;
2123    end Eval_Logical_Op;
2124
2125    ------------------------
2126    -- Eval_Membership_Op --
2127    ------------------------
2128
2129    --  A membership test is potentially static if the expression is static, and
2130    --  the range is a potentially static range, or is a subtype mark denoting a
2131    --  static subtype (RM 4.9(12)).
2132
2133    procedure Eval_Membership_Op (N : Node_Id) is
2134       Left   : constant Node_Id := Left_Opnd (N);
2135       Right  : constant Node_Id := Right_Opnd (N);
2136       Def_Id : Entity_Id;
2137       Lo     : Node_Id;
2138       Hi     : Node_Id;
2139       Result : Boolean;
2140       Stat   : Boolean;
2141       Fold   : Boolean;
2142
2143    begin
2144       --  Ignore if error in either operand, except to make sure that Any_Type
2145       --  is properly propagated to avoid junk cascaded errors.
2146
2147       if Etype (Left) = Any_Type
2148         or else Etype (Right) = Any_Type
2149       then
2150          Set_Etype (N, Any_Type);
2151          return;
2152       end if;
2153
2154       --  Case of right operand is a subtype name
2155
2156       if Is_Entity_Name (Right) then
2157          Def_Id := Entity (Right);
2158
2159          if (Is_Scalar_Type (Def_Id) or else Is_String_Type (Def_Id))
2160            and then Is_OK_Static_Subtype (Def_Id)
2161          then
2162             Test_Expression_Is_Foldable (N, Left, Stat, Fold);
2163
2164             if not Fold or else not Stat then
2165                return;
2166             end if;
2167          else
2168             Check_Non_Static_Context (Left);
2169             return;
2170          end if;
2171
2172          --  For string membership tests we will check the length further on
2173
2174          if not Is_String_Type (Def_Id) then
2175             Lo := Type_Low_Bound (Def_Id);
2176             Hi := Type_High_Bound (Def_Id);
2177
2178          else
2179             Lo := Empty;
2180             Hi := Empty;
2181          end if;
2182
2183       --  Case of right operand is a range
2184
2185       else
2186          if Is_Static_Range (Right) then
2187             Test_Expression_Is_Foldable (N, Left, Stat, Fold);
2188
2189             if not Fold or else not Stat then
2190                return;
2191
2192             --  If one bound of range raises CE, then don't try to fold
2193
2194             elsif not Is_OK_Static_Range (Right) then
2195                Check_Non_Static_Context (Left);
2196                return;
2197             end if;
2198
2199          else
2200             Check_Non_Static_Context (Left);
2201             return;
2202          end if;
2203
2204          --  Here we know range is an OK static range
2205
2206          Lo := Low_Bound (Right);
2207          Hi := High_Bound (Right);
2208       end if;
2209
2210       --  For strings we check that the length of the string expression is
2211       --  compatible with the string subtype if the subtype is constrained,
2212       --  or if unconstrained then the test is always true.
2213
2214       if Is_String_Type (Etype (Right)) then
2215          if not Is_Constrained (Etype (Right)) then
2216             Result := True;
2217
2218          else
2219             declare
2220                Typlen : constant Uint := String_Type_Len (Etype (Right));
2221                Strlen : constant Uint :=
2222                  UI_From_Int (String_Length (Strval (Get_String_Val (Left))));
2223             begin
2224                Result := (Typlen = Strlen);
2225             end;
2226          end if;
2227
2228       --  Fold the membership test. We know we have a static range and Lo and
2229       --  Hi are set to the expressions for the end points of this range.
2230
2231       elsif Is_Real_Type (Etype (Right)) then
2232          declare
2233             Leftval : constant Ureal := Expr_Value_R (Left);
2234
2235          begin
2236             Result := Expr_Value_R (Lo) <= Leftval
2237                         and then Leftval <= Expr_Value_R (Hi);
2238          end;
2239
2240       else
2241          declare
2242             Leftval : constant Uint := Expr_Value (Left);
2243
2244          begin
2245             Result := Expr_Value (Lo) <= Leftval
2246                         and then Leftval <= Expr_Value (Hi);
2247          end;
2248       end if;
2249
2250       if Nkind (N) = N_Not_In then
2251          Result := not Result;
2252       end if;
2253
2254       Fold_Uint (N, Test (Result), True);
2255       Warn_On_Known_Condition (N);
2256    end Eval_Membership_Op;
2257
2258    ------------------------
2259    -- Eval_Named_Integer --
2260    ------------------------
2261
2262    procedure Eval_Named_Integer (N : Node_Id) is
2263    begin
2264       Fold_Uint (N,
2265         Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
2266    end Eval_Named_Integer;
2267
2268    ---------------------
2269    -- Eval_Named_Real --
2270    ---------------------
2271
2272    procedure Eval_Named_Real (N : Node_Id) is
2273    begin
2274       Fold_Ureal (N,
2275         Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
2276    end Eval_Named_Real;
2277
2278    -------------------
2279    -- Eval_Op_Expon --
2280    -------------------
2281
2282    --  Exponentiation is a static functions, so the result is potentially
2283    --  static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2284
2285    procedure Eval_Op_Expon (N : Node_Id) is
2286       Left  : constant Node_Id := Left_Opnd (N);
2287       Right : constant Node_Id := Right_Opnd (N);
2288       Stat  : Boolean;
2289       Fold  : Boolean;
2290
2291    begin
2292       --  If not foldable we are done
2293
2294       Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2295
2296       if not Fold then
2297          return;
2298       end if;
2299
2300       --  Fold exponentiation operation
2301
2302       declare
2303          Right_Int : constant Uint := Expr_Value (Right);
2304
2305       begin
2306          --  Integer case
2307
2308          if Is_Integer_Type (Etype (Left)) then
2309             declare
2310                Left_Int : constant Uint := Expr_Value (Left);
2311                Result   : Uint;
2312
2313             begin
2314                --  Exponentiation of an integer raises the exception
2315                --  Constraint_Error for a negative exponent (RM 4.5.6)
2316
2317                if Right_Int < 0 then
2318                   Apply_Compile_Time_Constraint_Error
2319                     (N, "integer exponent negative",
2320                      CE_Range_Check_Failed,
2321                      Warn => not Stat);
2322                   return;
2323
2324                else
2325                   if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
2326                      Result := Left_Int ** Right_Int;
2327                   else
2328                      Result := Left_Int;
2329                   end if;
2330
2331                   if Is_Modular_Integer_Type (Etype (N)) then
2332                      Result := Result mod Modulus (Etype (N));
2333                   end if;
2334
2335                   Fold_Uint (N, Result, Stat);
2336                end if;
2337             end;
2338
2339          --  Real case
2340
2341          else
2342             declare
2343                Left_Real : constant Ureal := Expr_Value_R (Left);
2344
2345             begin
2346                --  Cannot have a zero base with a negative exponent
2347
2348                if UR_Is_Zero (Left_Real) then
2349
2350                   if Right_Int < 0 then
2351                      Apply_Compile_Time_Constraint_Error
2352                        (N, "zero ** negative integer",
2353                         CE_Range_Check_Failed,
2354                         Warn => not Stat);
2355                      return;
2356                   else
2357                      Fold_Ureal (N, Ureal_0, Stat);
2358                   end if;
2359
2360                else
2361                   Fold_Ureal (N, Left_Real ** Right_Int, Stat);
2362                end if;
2363             end;
2364          end if;
2365       end;
2366    end Eval_Op_Expon;
2367
2368    -----------------
2369    -- Eval_Op_Not --
2370    -----------------
2371
2372    --  The not operation is a  static functions, so the result is potentially
2373    --  static if the operand is potentially static (RM 4.9(7), 4.9(20)).
2374
2375    procedure Eval_Op_Not (N : Node_Id) is
2376       Right : constant Node_Id := Right_Opnd (N);
2377       Stat  : Boolean;
2378       Fold  : Boolean;
2379
2380    begin
2381       --  If not foldable we are done
2382
2383       Test_Expression_Is_Foldable (N, Right, Stat, Fold);
2384
2385       if not Fold then
2386          return;
2387       end if;
2388
2389       --  Fold not operation
2390
2391       declare
2392          Rint : constant Uint      := Expr_Value (Right);
2393          Typ  : constant Entity_Id := Etype (N);
2394
2395       begin
2396          --  Negation is equivalent to subtracting from the modulus minus one.
2397          --  For a binary modulus this is equivalent to the ones-complement of
2398          --  the original value. For non-binary modulus this is an arbitrary
2399          --  but consistent definition.
2400
2401          if Is_Modular_Integer_Type (Typ) then
2402             Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
2403
2404          else
2405             pragma Assert (Is_Boolean_Type (Typ));
2406             Fold_Uint (N, Test (not Is_True (Rint)), Stat);
2407          end if;
2408
2409          Set_Is_Static_Expression (N, Stat);
2410       end;
2411    end Eval_Op_Not;
2412
2413    -------------------------------
2414    -- Eval_Qualified_Expression --
2415    -------------------------------
2416
2417    --  A qualified expression is potentially static if its subtype mark denotes
2418    --  a static subtype and its expression is potentially static (RM 4.9 (11)).
2419
2420    procedure Eval_Qualified_Expression (N : Node_Id) is
2421       Operand     : constant Node_Id   := Expression (N);
2422       Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
2423
2424       Stat : Boolean;
2425       Fold : Boolean;
2426       Hex  : Boolean;
2427
2428    begin
2429       --  Can only fold if target is string or scalar and subtype is static.
2430       --  Also, do not fold if our parent is an allocator (this is because
2431       --  the qualified expression is really part of the syntactic structure
2432       --  of an allocator, and we do not want to end up with something that
2433       --  corresponds to "new 1" where the 1 is the result of folding a
2434       --  qualified expression).
2435
2436       if not Is_Static_Subtype (Target_Type)
2437         or else Nkind (Parent (N)) = N_Allocator
2438       then
2439          Check_Non_Static_Context (Operand);
2440
2441          --  If operand is known to raise constraint_error, set the flag on the
2442          --  expression so it does not get optimized away.
2443
2444          if Nkind (Operand) = N_Raise_Constraint_Error then
2445             Set_Raises_Constraint_Error (N);
2446          end if;
2447
2448          return;
2449       end if;
2450
2451       --  If not foldable we are done
2452
2453       Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
2454
2455       if not Fold then
2456          return;
2457
2458       --  Don't try fold if target type has constraint error bounds
2459
2460       elsif not Is_OK_Static_Subtype (Target_Type) then
2461          Set_Raises_Constraint_Error (N);
2462          return;
2463       end if;
2464
2465       --  Here we will fold, save Print_In_Hex indication
2466
2467       Hex := Nkind (Operand) = N_Integer_Literal
2468                and then Print_In_Hex (Operand);
2469
2470       --  Fold the result of qualification
2471
2472       if Is_Discrete_Type (Target_Type) then
2473          Fold_Uint (N, Expr_Value (Operand), Stat);
2474
2475          --  Preserve Print_In_Hex indication
2476
2477          if Hex and then Nkind (N) = N_Integer_Literal then
2478             Set_Print_In_Hex (N);
2479          end if;
2480
2481       elsif Is_Real_Type (Target_Type) then
2482          Fold_Ureal (N, Expr_Value_R (Operand), Stat);
2483
2484       else
2485          Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
2486
2487          if not Stat then
2488             Set_Is_Static_Expression (N, False);
2489          else
2490             Check_String_Literal_Length (N, Target_Type);
2491          end if;
2492
2493          return;
2494       end if;
2495
2496       --  The expression may be foldable but not static
2497
2498       Set_Is_Static_Expression (N, Stat);
2499
2500       if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
2501          Out_Of_Range (N);
2502       end if;
2503    end Eval_Qualified_Expression;
2504
2505    -----------------------
2506    -- Eval_Real_Literal --
2507    -----------------------
2508
2509    --  Numeric literals are static (RM 4.9(1)), and have already been marked
2510    --  as static by the analyzer. The reason we did it that early is to allow
2511    --  the possibility of turning off the Is_Static_Expression flag after
2512    --  analysis, but before resolution, when integer literals are generated
2513    --  in the expander that do not correspond to static expressions.
2514
2515    procedure Eval_Real_Literal (N : Node_Id) is
2516       PK : constant Node_Kind := Nkind (Parent (N));
2517
2518    begin
2519       --  If the literal appears in a non-expression context and not as part of
2520       --  a number declaration, then it is appearing in a non-static context,
2521       --  so check it.
2522
2523       if PK not in N_Subexpr and then PK /= N_Number_Declaration then
2524          Check_Non_Static_Context (N);
2525       end if;
2526    end Eval_Real_Literal;
2527
2528    ------------------------
2529    -- Eval_Relational_Op --
2530    ------------------------
2531
2532    --  Relational operations are static functions, so the result is static
2533    --  if both operands are static (RM 4.9(7), 4.9(20)), except that for
2534    --  strings, the result is never static, even if the operands are.
2535
2536    procedure Eval_Relational_Op (N : Node_Id) is
2537       Left   : constant Node_Id   := Left_Opnd (N);
2538       Right  : constant Node_Id   := Right_Opnd (N);
2539       Typ    : constant Entity_Id := Etype (Left);
2540       Result : Boolean;
2541       Stat   : Boolean;
2542       Fold   : Boolean;
2543
2544    begin
2545       --  One special case to deal with first. If we can tell that the result
2546       --  will be false because the lengths of one or more index subtypes are
2547       --  compile time known and different, then we can replace the entire
2548       --  result by False. We only do this for one dimensional arrays, because
2549       --  the case of multi-dimensional arrays is rare and too much trouble! If
2550       --  one of the operands is an illegal aggregate, its type might still be
2551       --  an arbitrary composite type, so nothing to do.
2552
2553       if Is_Array_Type (Typ)
2554         and then Typ /= Any_Composite
2555         and then Number_Dimensions (Typ) = 1
2556         and then (Nkind (N) = N_Op_Eq or else Nkind (N) = N_Op_Ne)
2557       then
2558          if Raises_Constraint_Error (Left)
2559            or else Raises_Constraint_Error (Right)
2560          then
2561             return;
2562          end if;
2563
2564          --  OK, we have the case where we may be able to do this fold
2565
2566          Length_Mismatch : declare
2567             procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
2568             --  If Op is an expression for a constrained array with a known at
2569             --  compile time length, then Len is set to this (non-negative
2570             --  length). Otherwise Len is set to minus 1.
2571
2572             -----------------------
2573             -- Get_Static_Length --
2574             -----------------------
2575
2576             procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
2577                T : Entity_Id;
2578
2579             begin
2580                --  First easy case string literal
2581
2582                if Nkind (Op) = N_String_Literal then
2583                   Len := UI_From_Int (String_Length (Strval (Op)));
2584                   return;
2585                end if;
2586
2587                --  Second easy case, not constrained subtype, so no length
2588
2589                if not Is_Constrained (Etype (Op)) then
2590                   Len := Uint_Minus_1;
2591                   return;
2592                end if;
2593
2594                --  General case
2595
2596                T := Etype (First_Index (Etype (Op)));
2597
2598                --  The simple case, both bounds are known at compile time
2599
2600                if Is_Discrete_Type (T)
2601                  and then
2602                    Compile_Time_Known_Value (Type_Low_Bound (T))
2603                  and then
2604                    Compile_Time_Known_Value (Type_High_Bound (T))
2605                then
2606                   Len := UI_Max (Uint_0,
2607                                  Expr_Value (Type_High_Bound (T)) -
2608                                    Expr_Value (Type_Low_Bound  (T)) + 1);
2609                   return;
2610                end if;
2611
2612                --  A more complex case, where the bounds are of the form
2613                --  X [+/- K1] .. X [+/- K2]), where X is an expression that is
2614                --  either A'First or A'Last (with A an entity name), or X is an
2615                --  entity name, and the two X's are the same and K1 and K2 are
2616                --  known at compile time, in this case, the length can also be
2617                --  computed at compile time, even though the bounds are not
2618                --  known. A common case of this is e.g. (X'First..X'First+5).
2619
2620                Extract_Length : declare
2621                   procedure Decompose_Expr
2622                     (Expr : Node_Id;
2623                      Ent  : out Entity_Id;
2624                      Kind : out Character;
2625                      Cons : out Uint);
2626                   --  Given an expression, see if is of the form above,
2627                   --  X [+/- K]. If so Ent is set to the entity in X,
2628                   --  Kind is 'F','L','E' for 'First/'Last/simple entity,
2629                   --  and Cons is the value of K. If the expression is
2630                   --  not of the required form, Ent is set to Empty.
2631
2632                   --------------------
2633                   -- Decompose_Expr --
2634                   --------------------
2635
2636                   procedure Decompose_Expr
2637                     (Expr : Node_Id;
2638                      Ent  : out Entity_Id;
2639                      Kind : out Character;
2640                      Cons : out Uint)
2641                   is
2642                      Exp : Node_Id;
2643
2644                   begin
2645                      if Nkind (Expr) = N_Op_Add
2646                        and then Compile_Time_Known_Value (Right_Opnd (Expr))
2647                      then
2648                         Exp := Left_Opnd (Expr);
2649                         Cons := Expr_Value (Right_Opnd (Expr));
2650
2651                      elsif Nkind (Expr) = N_Op_Subtract
2652                        and then Compile_Time_Known_Value (Right_Opnd (Expr))
2653                      then
2654                         Exp := Left_Opnd (Expr);
2655                         Cons := -Expr_Value (Right_Opnd (Expr));
2656
2657                      else
2658                         Exp := Expr;
2659                         Cons := Uint_0;
2660                      end if;
2661
2662                      --  At this stage Exp is set to the potential X
2663
2664                      if Nkind (Exp) = N_Attribute_Reference then
2665                         if Attribute_Name (Exp) = Name_First then
2666                            Kind := 'F';
2667                         elsif Attribute_Name (Exp) = Name_Last then
2668                            Kind := 'L';
2669                         else
2670                            Ent := Empty;
2671                            return;
2672                         end if;
2673
2674                         Exp := Prefix (Exp);
2675
2676                      else
2677                         Kind := 'E';
2678                      end if;
2679
2680                      if Is_Entity_Name (Exp)
2681                        and then Present (Entity (Exp))
2682                      then
2683                         Ent := Entity (Exp);
2684                      else
2685                         Ent := Empty;
2686                      end if;
2687                   end Decompose_Expr;
2688
2689                   --  Local Variables
2690
2691                   Ent1,  Ent2  : Entity_Id;
2692                   Kind1, Kind2 : Character;
2693                   Cons1, Cons2 : Uint;
2694
2695                --  Start of processing for Extract_Length
2696
2697                begin
2698                   Decompose_Expr
2699                     (Original_Node (Type_Low_Bound  (T)), Ent1, Kind1, Cons1);
2700                   Decompose_Expr
2701                     (Original_Node (Type_High_Bound (T)), Ent2, Kind2, Cons2);
2702
2703                   if Present (Ent1)
2704                     and then Kind1 = Kind2
2705                     and then Ent1 = Ent2
2706                   then
2707                      Len := Cons2 - Cons1 + 1;
2708                   else
2709                      Len := Uint_Minus_1;
2710                   end if;
2711                end Extract_Length;
2712             end Get_Static_Length;
2713
2714             --  Local Variables
2715
2716             Len_L : Uint;
2717             Len_R : Uint;
2718
2719          --  Start of processing for Length_Mismatch
2720
2721          begin
2722             Get_Static_Length (Left,  Len_L);
2723             Get_Static_Length (Right, Len_R);
2724
2725             if Len_L /= Uint_Minus_1
2726               and then Len_R /= Uint_Minus_1
2727               and then Len_L /= Len_R
2728             then
2729                Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
2730                Warn_On_Known_Condition (N);
2731                return;
2732             end if;
2733          end Length_Mismatch;
2734       end if;
2735
2736       --  Test for expression being foldable
2737
2738       Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2739
2740       --  Only comparisons of scalars can give static results. In particular,
2741       --  comparisons of strings never yield a static result, even if both
2742       --  operands are static strings.
2743
2744       if not Is_Scalar_Type (Typ) then
2745          Stat := False;
2746          Set_Is_Static_Expression (N, False);
2747       end if;
2748
2749       --  For static real type expressions, we cannot use Compile_Time_Compare
2750       --  since it worries about run-time results which are not exact.
2751
2752       if Stat and then Is_Real_Type (Typ) then
2753          declare
2754             Left_Real  : constant Ureal := Expr_Value_R (Left);
2755             Right_Real : constant Ureal := Expr_Value_R (Right);
2756
2757          begin
2758             case Nkind (N) is
2759                when N_Op_Eq => Result := (Left_Real =  Right_Real);
2760                when N_Op_Ne => Result := (Left_Real /= Right_Real);
2761                when N_Op_Lt => Result := (Left_Real <  Right_Real);
2762                when N_Op_Le => Result := (Left_Real <= Right_Real);
2763                when N_Op_Gt => Result := (Left_Real >  Right_Real);
2764                when N_Op_Ge => Result := (Left_Real >= Right_Real);
2765
2766                when others =>
2767                   raise Program_Error;
2768             end case;
2769
2770             Fold_Uint (N, Test (Result), True);
2771          end;
2772
2773       --  For all other cases, we use Compile_Time_Compare to do the compare
2774
2775       else
2776          declare
2777             CR : constant Compare_Result :=
2778                    Compile_Time_Compare (Left, Right, Assume_Valid => False);
2779
2780          begin
2781             if CR = Unknown then
2782                return;
2783             end if;
2784
2785             case Nkind (N) is
2786                when N_Op_Eq =>
2787                   if CR = EQ then
2788                      Result := True;
2789                   elsif CR = NE or else CR = GT or else CR = LT then
2790                      Result := False;
2791                   else
2792                      return;
2793                   end if;
2794
2795                when N_Op_Ne =>
2796                   if CR = NE or else CR = GT or else CR = LT then
2797                      Result := True;
2798                   elsif CR = EQ then
2799                      Result := False;
2800                   else
2801                      return;
2802                   end if;
2803
2804                when N_Op_Lt =>
2805                   if CR = LT then
2806                      Result := True;
2807                   elsif CR = EQ or else CR = GT or else CR = GE then
2808                      Result := False;
2809                   else
2810                      return;
2811                   end if;
2812
2813                when N_Op_Le =>
2814                   if CR = LT or else CR = EQ or else CR = LE then
2815                      Result := True;
2816                   elsif CR = GT then
2817                      Result := False;
2818                   else
2819                      return;
2820                   end if;
2821
2822                when N_Op_Gt =>
2823                   if CR = GT then
2824                      Result := True;
2825                   elsif CR = EQ or else CR = LT or else CR = LE then
2826                      Result := False;
2827                   else
2828                      return;
2829                   end if;
2830
2831                when N_Op_Ge =>
2832                   if CR = GT or else CR = EQ or else CR = GE then
2833                      Result := True;
2834                   elsif CR = LT then
2835                      Result := False;
2836                   else
2837                      return;
2838                   end if;
2839
2840                when others =>
2841                   raise Program_Error;
2842             end case;
2843          end;
2844
2845          Fold_Uint (N, Test (Result), Stat);
2846       end if;
2847
2848       Warn_On_Known_Condition (N);
2849    end Eval_Relational_Op;
2850
2851    ----------------
2852    -- Eval_Shift --
2853    ----------------
2854
2855    --  Shift operations are intrinsic operations that can never be static,
2856    --  so the only processing required is to perform the required check for
2857    --  a non static context for the two operands.
2858
2859    --  Actually we could do some compile time evaluation here some time ???
2860
2861    procedure Eval_Shift (N : Node_Id) is
2862    begin
2863       Check_Non_Static_Context (Left_Opnd (N));
2864       Check_Non_Static_Context (Right_Opnd (N));
2865    end Eval_Shift;
2866
2867    ------------------------
2868    -- Eval_Short_Circuit --
2869    ------------------------
2870
2871    --  A short circuit operation is potentially static if both operands
2872    --  are potentially static (RM 4.9 (13))
2873
2874    procedure Eval_Short_Circuit (N : Node_Id) is
2875       Kind     : constant Node_Kind := Nkind (N);
2876       Left     : constant Node_Id   := Left_Opnd (N);
2877       Right    : constant Node_Id   := Right_Opnd (N);
2878       Left_Int : Uint;
2879       Rstat    : constant Boolean   :=
2880                    Is_Static_Expression (Left)
2881                      and then Is_Static_Expression (Right);
2882
2883    begin
2884       --  Short circuit operations are never static in Ada 83
2885
2886       if Ada_Version = Ada_83
2887         and then Comes_From_Source (N)
2888       then
2889          Check_Non_Static_Context (Left);
2890          Check_Non_Static_Context (Right);
2891          return;
2892       end if;
2893
2894       --  Now look at the operands, we can't quite use the normal call to
2895       --  Test_Expression_Is_Foldable here because short circuit operations
2896       --  are a special case, they can still be foldable, even if the right
2897       --  operand raises constraint error.
2898
2899       --  If either operand is Any_Type, just propagate to result and
2900       --  do not try to fold, this prevents cascaded errors.
2901
2902       if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
2903          Set_Etype (N, Any_Type);
2904          return;
2905
2906       --  If left operand raises constraint error, then replace node N with
2907       --  the raise constraint error node, and we are obviously not foldable.
2908       --  Is_Static_Expression is set from the two operands in the normal way,
2909       --  and we check the right operand if it is in a non-static context.
2910
2911       elsif Raises_Constraint_Error (Left) then
2912          if not Rstat then
2913             Check_Non_Static_Context (Right);
2914          end if;
2915
2916          Rewrite_In_Raise_CE (N, Left);
2917          Set_Is_Static_Expression (N, Rstat);
2918          return;
2919
2920       --  If the result is not static, then we won't in any case fold
2921
2922       elsif not Rstat then
2923          Check_Non_Static_Context (Left);
2924          Check_Non_Static_Context (Right);
2925          return;
2926       end if;
2927
2928       --  Here the result is static, note that, unlike the normal processing
2929       --  in Test_Expression_Is_Foldable, we did *not* check above to see if
2930       --  the right operand raises constraint error, that's because it is not
2931       --  significant if the left operand is decisive.
2932
2933       Set_Is_Static_Expression (N);
2934
2935       --  It does not matter if the right operand raises constraint error if
2936       --  it will not be evaluated. So deal specially with the cases where
2937       --  the right operand is not evaluated. Note that we will fold these
2938       --  cases even if the right operand is non-static, which is fine, but
2939       --  of course in these cases the result is not potentially static.
2940
2941       Left_Int := Expr_Value (Left);
2942
2943       if (Kind = N_And_Then and then Is_False (Left_Int))
2944             or else
2945          (Kind = N_Or_Else  and then Is_True (Left_Int))
2946       then
2947          Fold_Uint (N, Left_Int, Rstat);
2948          return;
2949       end if;
2950
2951       --  If first operand not decisive, then it does matter if the right
2952       --  operand raises constraint error, since it will be evaluated, so
2953       --  we simply replace the node with the right operand. Note that this
2954       --  properly propagates Is_Static_Expression and Raises_Constraint_Error
2955       --  (both are set to True in Right).
2956
2957       if Raises_Constraint_Error (Right) then
2958          Rewrite_In_Raise_CE (N, Right);
2959          Check_Non_Static_Context (Left);
2960          return;
2961       end if;
2962
2963       --  Otherwise the result depends on the right operand
2964
2965       Fold_Uint (N, Expr_Value (Right), Rstat);
2966       return;
2967    end Eval_Short_Circuit;
2968
2969    ----------------
2970    -- Eval_Slice --
2971    ----------------
2972
2973    --  Slices can never be static, so the only processing required is to
2974    --  check for non-static context if an explicit range is given.
2975
2976    procedure Eval_Slice (N : Node_Id) is
2977       Drange : constant Node_Id := Discrete_Range (N);
2978    begin
2979       if Nkind (Drange) = N_Range then
2980          Check_Non_Static_Context (Low_Bound (Drange));
2981          Check_Non_Static_Context (High_Bound (Drange));
2982       end if;
2983
2984       --  A slice of the form  A (subtype), when the subtype is the index of
2985       --  the type of A, is redundant, the slice can be replaced with A, and
2986       --  this is worth a warning.
2987
2988       if Is_Entity_Name (Prefix (N)) then
2989          declare
2990             E : constant Entity_Id := Entity (Prefix (N));
2991             T : constant Entity_Id := Etype (E);
2992          begin
2993             if Ekind (E) = E_Constant
2994               and then Is_Array_Type (T)
2995               and then Is_Entity_Name (Drange)
2996             then
2997                if Is_Entity_Name (Original_Node (First_Index (T)))
2998                  and then Entity (Original_Node (First_Index (T)))
2999                     = Entity (Drange)
3000                then
3001                   if Warn_On_Redundant_Constructs then
3002                      Error_Msg_N ("redundant slice denotes whole array?", N);
3003                   end if;
3004
3005                   --  The following might be a useful optimization ????
3006
3007                   --  Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
3008                end if;
3009             end if;
3010          end;
3011       end if;
3012    end Eval_Slice;
3013
3014    -------------------------
3015    -- Eval_String_Literal --
3016    -------------------------
3017
3018    procedure Eval_String_Literal (N : Node_Id) is
3019       Typ : constant Entity_Id := Etype (N);
3020       Bas : constant Entity_Id := Base_Type (Typ);
3021       Xtp : Entity_Id;
3022       Len : Nat;
3023       Lo  : Node_Id;
3024
3025    begin
3026       --  Nothing to do if error type (handles cases like default expressions
3027       --  or generics where we have not yet fully resolved the type)
3028
3029       if Bas = Any_Type or else Bas = Any_String then
3030          return;
3031       end if;
3032
3033       --  String literals are static if the subtype is static (RM 4.9(2)), so
3034       --  reset the static expression flag (it was set unconditionally in
3035       --  Analyze_String_Literal) if the subtype is non-static. We tell if
3036       --  the subtype is static by looking at the lower bound.
3037
3038       if Ekind (Typ) = E_String_Literal_Subtype then
3039          if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
3040             Set_Is_Static_Expression (N, False);
3041             return;
3042          end if;
3043
3044       --  Here if Etype of string literal is normal Etype (not yet possible,
3045       --  but may be possible in future!)
3046
3047       elsif not Is_OK_Static_Expression
3048                     (Type_Low_Bound (Etype (First_Index (Typ))))
3049       then
3050          Set_Is_Static_Expression (N, False);
3051          return;
3052       end if;
3053
3054       --  If original node was a type conversion, then result if non-static
3055
3056       if Nkind (Original_Node (N)) = N_Type_Conversion then
3057          Set_Is_Static_Expression (N, False);
3058          return;
3059       end if;
3060
3061       --  Test for illegal Ada 95 cases. A string literal is illegal in
3062       --  Ada 95 if its bounds are outside the index base type and this
3063       --  index type is static. This can happen in only two ways. Either
3064       --  the string literal is too long, or it is null, and the lower
3065       --  bound is type'First. In either case it is the upper bound that
3066       --  is out of range of the index type.
3067
3068       if Ada_Version >= Ada_95 then
3069          if Root_Type (Bas) = Standard_String
3070               or else
3071             Root_Type (Bas) = Standard_Wide_String
3072          then
3073             Xtp := Standard_Positive;
3074          else
3075             Xtp := Etype (First_Index (Bas));
3076          end if;
3077
3078          if Ekind (Typ) = E_String_Literal_Subtype then
3079             Lo := String_Literal_Low_Bound (Typ);
3080          else
3081             Lo := Type_Low_Bound (Etype (First_Index (Typ)));
3082          end if;
3083
3084          Len := String_Length (Strval (N));
3085
3086          if UI_From_Int (Len) > String_Type_Len (Bas) then
3087             Apply_Compile_Time_Constraint_Error
3088               (N, "string literal too long for}", CE_Length_Check_Failed,
3089                Ent => Bas,
3090                Typ => First_Subtype (Bas));
3091
3092          elsif Len = 0
3093            and then not Is_Generic_Type (Xtp)
3094            and then
3095              Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
3096          then
3097             Apply_Compile_Time_Constraint_Error
3098               (N, "null string literal not allowed for}",
3099                CE_Length_Check_Failed,
3100                Ent => Bas,
3101                Typ => First_Subtype (Bas));
3102          end if;
3103       end if;
3104    end Eval_String_Literal;
3105
3106    --------------------------
3107    -- Eval_Type_Conversion --
3108    --------------------------
3109
3110    --  A type conversion is potentially static if its subtype mark is for a
3111    --  static scalar subtype, and its operand expression is potentially static
3112    --  (RM 4.9 (10))
3113
3114    procedure Eval_Type_Conversion (N : Node_Id) is
3115       Operand     : constant Node_Id   := Expression (N);
3116       Source_Type : constant Entity_Id := Etype (Operand);
3117       Target_Type : constant Entity_Id := Etype (N);
3118
3119       Stat   : Boolean;
3120       Fold   : Boolean;
3121
3122       function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
3123       --  Returns true if type T is an integer type, or if it is a
3124       --  fixed-point type to be treated as an integer (i.e. the flag
3125       --  Conversion_OK is set on the conversion node).
3126
3127       function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
3128       --  Returns true if type T is a floating-point type, or if it is a
3129       --  fixed-point type that is not to be treated as an integer (i.e. the
3130       --  flag Conversion_OK is not set on the conversion node).
3131
3132       ------------------------------
3133       -- To_Be_Treated_As_Integer --
3134       ------------------------------
3135
3136       function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
3137       begin
3138          return
3139            Is_Integer_Type (T)
3140              or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
3141       end To_Be_Treated_As_Integer;
3142
3143       ---------------------------
3144       -- To_Be_Treated_As_Real --
3145       ---------------------------
3146
3147       function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
3148       begin
3149          return
3150            Is_Floating_Point_Type (T)
3151              or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
3152       end To_Be_Treated_As_Real;
3153
3154    --  Start of processing for Eval_Type_Conversion
3155
3156    begin
3157       --  Cannot fold if target type is non-static or if semantic error
3158
3159       if not Is_Static_Subtype (Target_Type) then
3160          Check_Non_Static_Context (Operand);
3161          return;
3162
3163       elsif Error_Posted (N) then
3164          return;
3165       end if;
3166
3167       --  If not foldable we are done
3168
3169       Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
3170
3171       if not Fold then
3172          return;
3173
3174       --  Don't try fold if target type has constraint error bounds
3175
3176       elsif not Is_OK_Static_Subtype (Target_Type) then
3177          Set_Raises_Constraint_Error (N);
3178          return;
3179       end if;
3180
3181       --  Remaining processing depends on operand types. Note that in the
3182       --  following type test, fixed-point counts as real unless the flag
3183       --  Conversion_OK is set, in which case it counts as integer.
3184
3185       --  Fold conversion, case of string type. The result is not static
3186
3187       if Is_String_Type (Target_Type) then
3188          Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
3189
3190          return;
3191
3192       --  Fold conversion, case of integer target type
3193
3194       elsif To_Be_Treated_As_Integer (Target_Type) then
3195          declare
3196             Result : Uint;
3197
3198          begin
3199             --  Integer to integer conversion
3200
3201             if To_Be_Treated_As_Integer (Source_Type) then
3202                Result := Expr_Value (Operand);
3203
3204             --  Real to integer conversion
3205
3206             else
3207                Result := UR_To_Uint (Expr_Value_R (Operand));
3208             end if;
3209
3210             --  If fixed-point type (Conversion_OK must be set), then the
3211             --  result is logically an integer, but we must replace the
3212             --  conversion with the corresponding real literal, since the
3213             --  type from a semantic point of view is still fixed-point.
3214
3215             if Is_Fixed_Point_Type (Target_Type) then
3216                Fold_Ureal
3217                  (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
3218
3219             --  Otherwise result is integer literal
3220
3221             else
3222                Fold_Uint (N, Result, Stat);
3223             end if;
3224          end;
3225
3226       --  Fold conversion, case of real target type
3227
3228       elsif To_Be_Treated_As_Real (Target_Type) then
3229          declare
3230             Result : Ureal;
3231
3232          begin
3233             if To_Be_Treated_As_Real (Source_Type) then
3234                Result := Expr_Value_R (Operand);
3235             else
3236                Result := UR_From_Uint (Expr_Value (Operand));
3237             end if;
3238
3239             Fold_Ureal (N, Result, Stat);
3240          end;
3241
3242       --  Enumeration types
3243
3244       else
3245          Fold_Uint (N, Expr_Value (Operand), Stat);
3246       end if;
3247
3248       if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3249          Out_Of_Range (N);
3250       end if;
3251
3252    end Eval_Type_Conversion;
3253
3254    -------------------
3255    -- Eval_Unary_Op --
3256    -------------------
3257
3258    --  Predefined unary operators are static functions (RM 4.9(20)) and thus
3259    --  are potentially static if the operand is potentially static (RM 4.9(7))
3260
3261    procedure Eval_Unary_Op (N : Node_Id) is
3262       Right : constant Node_Id := Right_Opnd (N);
3263       Stat  : Boolean;
3264       Fold  : Boolean;
3265
3266    begin
3267       --  If not foldable we are done
3268
3269       Test_Expression_Is_Foldable (N, Right, Stat, Fold);
3270
3271       if not Fold then
3272          return;
3273       end if;
3274
3275       --  Fold for integer case
3276
3277       if Is_Integer_Type (Etype (N)) then
3278          declare
3279             Rint   : constant Uint := Expr_Value (Right);
3280             Result : Uint;
3281
3282          begin
3283             --  In the case of modular unary plus and abs there is no need
3284             --  to adjust the result of the operation since if the original
3285             --  operand was in bounds the result will be in the bounds of the
3286             --  modular type. However, in the case of modular unary minus the
3287             --  result may go out of the bounds of the modular type and needs
3288             --  adjustment.
3289
3290             if Nkind (N) = N_Op_Plus then
3291                Result := Rint;
3292
3293             elsif Nkind (N) = N_Op_Minus then
3294                if Is_Modular_Integer_Type (Etype (N)) then
3295                   Result := (-Rint) mod Modulus (Etype (N));
3296                else
3297                   Result := (-Rint);
3298                end if;
3299
3300             else
3301                pragma Assert (Nkind (N) = N_Op_Abs);
3302                Result := abs Rint;
3303             end if;
3304
3305             Fold_Uint (N, Result, Stat);
3306          end;
3307
3308       --  Fold for real case
3309
3310       elsif Is_Real_Type (Etype (N)) then
3311          declare
3312             Rreal  : constant Ureal := Expr_Value_R (Right);
3313             Result : Ureal;
3314
3315          begin
3316             if Nkind (N) = N_Op_Plus then
3317                Result := Rreal;
3318
3319             elsif Nkind (N) = N_Op_Minus then
3320                Result := UR_Negate (Rreal);
3321
3322             else
3323                pragma Assert (Nkind (N) = N_Op_Abs);
3324                Result := abs Rreal;
3325             end if;
3326
3327             Fold_Ureal (N, Result, Stat);
3328          end;
3329       end if;
3330    end Eval_Unary_Op;
3331
3332    -------------------------------
3333    -- Eval_Unchecked_Conversion --
3334    -------------------------------
3335
3336    --  Unchecked conversions can never be static, so the only required
3337    --  processing is to check for a non-static context for the operand.
3338
3339    procedure Eval_Unchecked_Conversion (N : Node_Id) is
3340    begin
3341       Check_Non_Static_Context (Expression (N));
3342    end Eval_Unchecked_Conversion;
3343
3344    --------------------
3345    -- Expr_Rep_Value --
3346    --------------------
3347
3348    function Expr_Rep_Value (N : Node_Id) return Uint is
3349       Kind : constant Node_Kind := Nkind (N);
3350       Ent  : Entity_Id;
3351
3352    begin
3353       if Is_Entity_Name (N) then
3354          Ent := Entity (N);
3355
3356          --  An enumeration literal that was either in the source or
3357          --  created as a result of static evaluation.
3358
3359          if Ekind (Ent) = E_Enumeration_Literal then
3360             return Enumeration_Rep (Ent);
3361
3362          --  A user defined static constant
3363
3364          else
3365             pragma Assert (Ekind (Ent) = E_Constant);
3366             return Expr_Rep_Value (Constant_Value (Ent));
3367          end if;
3368
3369       --  An integer literal that was either in the source or created
3370       --  as a result of static evaluation.
3371
3372       elsif Kind = N_Integer_Literal then
3373          return Intval (N);
3374
3375       --  A real literal for a fixed-point type. This must be the fixed-point
3376       --  case, either the literal is of a fixed-point type, or it is a bound
3377       --  of a fixed-point type, with type universal real. In either case we
3378       --  obtain the desired value from Corresponding_Integer_Value.
3379
3380       elsif Kind = N_Real_Literal then
3381          pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3382          return Corresponding_Integer_Value (N);
3383
3384       --  Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3385
3386       elsif Kind = N_Attribute_Reference
3387         and then Attribute_Name (N) = Name_Null_Parameter
3388       then
3389          return Uint_0;
3390
3391       --  Otherwise must be character literal
3392
3393       else
3394          pragma Assert (Kind = N_Character_Literal);
3395          Ent := Entity (N);
3396
3397          --  Since Character literals of type Standard.Character don't
3398          --  have any defining character literals built for them, they
3399          --  do not have their Entity set, so just use their Char
3400          --  code. Otherwise for user-defined character literals use
3401          --  their Pos value as usual which is the same as the Rep value.
3402
3403          if No (Ent) then
3404             return Char_Literal_Value (N);
3405          else
3406             return Enumeration_Rep (Ent);
3407          end if;
3408       end if;
3409    end Expr_Rep_Value;
3410
3411    ----------------
3412    -- Expr_Value --
3413    ----------------
3414
3415    function Expr_Value (N : Node_Id) return Uint is
3416       Kind   : constant Node_Kind := Nkind (N);
3417       CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
3418       Ent    : Entity_Id;
3419       Val    : Uint;
3420
3421    begin
3422       --  If already in cache, then we know it's compile time known and we can
3423       --  return the value that was previously stored in the cache since
3424       --  compile time known values cannot change.
3425
3426       if CV_Ent.N = N then
3427          return CV_Ent.V;
3428       end if;
3429
3430       --  Otherwise proceed to test value
3431
3432       if Is_Entity_Name (N) then
3433          Ent := Entity (N);
3434
3435          --  An enumeration literal that was either in the source or
3436          --  created as a result of static evaluation.
3437
3438          if Ekind (Ent) = E_Enumeration_Literal then
3439             Val := Enumeration_Pos (Ent);
3440
3441          --  A user defined static constant
3442
3443          else
3444             pragma Assert (Ekind (Ent) = E_Constant);
3445             Val := Expr_Value (Constant_Value (Ent));
3446          end if;
3447
3448       --  An integer literal that was either in the source or created
3449       --  as a result of static evaluation.
3450
3451       elsif Kind = N_Integer_Literal then
3452          Val := Intval (N);
3453
3454       --  A real literal for a fixed-point type. This must be the fixed-point
3455       --  case, either the literal is of a fixed-point type, or it is a bound
3456       --  of a fixed-point type, with type universal real. In either case we
3457       --  obtain the desired value from Corresponding_Integer_Value.
3458
3459       elsif Kind = N_Real_Literal then
3460
3461          pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3462          Val := Corresponding_Integer_Value (N);
3463
3464       --  Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3465
3466       elsif Kind = N_Attribute_Reference
3467         and then Attribute_Name (N) = Name_Null_Parameter
3468       then
3469          Val := Uint_0;
3470
3471       --  Otherwise must be character literal
3472
3473       else
3474          pragma Assert (Kind = N_Character_Literal);
3475          Ent := Entity (N);
3476
3477          --  Since Character literals of type Standard.Character don't
3478          --  have any defining character literals built for them, they
3479          --  do not have their Entity set, so just use their Char
3480          --  code. Otherwise for user-defined character literals use
3481          --  their Pos value as usual.
3482
3483          if No (Ent) then
3484             Val := Char_Literal_Value (N);
3485          else
3486             Val := Enumeration_Pos (Ent);
3487          end if;
3488       end if;
3489
3490       --  Come here with Val set to value to be returned, set cache
3491
3492       CV_Ent.N := N;
3493       CV_Ent.V := Val;
3494       return Val;
3495    end Expr_Value;
3496
3497    ------------------
3498    -- Expr_Value_E --
3499    ------------------
3500
3501    function Expr_Value_E (N : Node_Id) return Entity_Id is
3502       Ent  : constant Entity_Id := Entity (N);
3503
3504    begin
3505       if Ekind (Ent) = E_Enumeration_Literal then
3506          return Ent;
3507       else
3508          pragma Assert (Ekind (Ent) = E_Constant);
3509          return Expr_Value_E (Constant_Value (Ent));
3510       end if;
3511    end Expr_Value_E;
3512
3513    ------------------
3514    -- Expr_Value_R --
3515    ------------------
3516
3517    function Expr_Value_R (N : Node_Id) return Ureal is
3518       Kind : constant Node_Kind := Nkind (N);
3519       Ent  : Entity_Id;
3520       Expr : Node_Id;
3521
3522    begin
3523       if Kind = N_Real_Literal then
3524          return Realval (N);
3525
3526       elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
3527          Ent := Entity (N);
3528          pragma Assert (Ekind (Ent) = E_Constant);
3529          return Expr_Value_R (Constant_Value (Ent));
3530
3531       elsif Kind = N_Integer_Literal then
3532          return UR_From_Uint (Expr_Value (N));
3533
3534       --  Strange case of VAX literals, which are at this stage transformed
3535       --  into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in
3536       --  Exp_Vfpt for further details.
3537
3538       elsif Vax_Float (Etype (N))
3539         and then Nkind (N) = N_Unchecked_Type_Conversion
3540       then
3541          Expr := Expression (N);
3542
3543          if Nkind (Expr) = N_Function_Call
3544            and then Present (Parameter_Associations (Expr))
3545          then
3546             Expr := First (Parameter_Associations (Expr));
3547
3548             if Nkind (Expr) = N_Real_Literal then
3549                return Realval (Expr);
3550             end if;
3551          end if;
3552
3553       --  Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
3554
3555       elsif Kind = N_Attribute_Reference
3556         and then Attribute_Name (N) = Name_Null_Parameter
3557       then
3558          return Ureal_0;
3559       end if;
3560
3561       --  If we fall through, we have a node that cannot be interpreted
3562       --  as a compile time constant. That is definitely an error.
3563
3564       raise Program_Error;
3565    end Expr_Value_R;
3566
3567    ------------------
3568    -- Expr_Value_S --
3569    ------------------
3570
3571    function Expr_Value_S (N : Node_Id) return Node_Id is
3572    begin
3573       if Nkind (N) = N_String_Literal then
3574          return N;
3575       else
3576          pragma Assert (Ekind (Entity (N)) = E_Constant);
3577          return Expr_Value_S (Constant_Value (Entity (N)));
3578       end if;
3579    end Expr_Value_S;
3580
3581    --------------------------
3582    -- Flag_Non_Static_Expr --
3583    --------------------------
3584
3585    procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
3586    begin
3587       if Error_Posted (Expr) and then not All_Errors_Mode then
3588          return;
3589       else
3590          Error_Msg_F (Msg, Expr);
3591          Why_Not_Static (Expr);
3592       end if;
3593    end Flag_Non_Static_Expr;
3594
3595    --------------
3596    -- Fold_Str --
3597    --------------
3598
3599    procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
3600       Loc : constant Source_Ptr := Sloc (N);
3601       Typ : constant Entity_Id  := Etype (N);
3602
3603    begin
3604       Rewrite (N, Make_String_Literal (Loc, Strval => Val));
3605
3606       --  We now have the literal with the right value, both the actual type
3607       --  and the expected type of this literal are taken from the expression
3608       --  that was evaluated.
3609
3610       Analyze (N);
3611       Set_Is_Static_Expression (N, Static);
3612       Set_Etype (N, Typ);
3613       Resolve (N);
3614    end Fold_Str;
3615
3616    ---------------
3617    -- Fold_Uint --
3618    ---------------
3619
3620    procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
3621       Loc : constant Source_Ptr := Sloc (N);
3622       Typ : Entity_Id  := Etype (N);
3623       Ent : Entity_Id;
3624
3625    begin
3626       --  If we are folding a named number, retain the entity in the
3627       --  literal, for ASIS use.
3628
3629       if Is_Entity_Name (N)
3630         and then Ekind (Entity (N)) = E_Named_Integer
3631       then
3632          Ent := Entity (N);
3633       else
3634          Ent := Empty;
3635       end if;
3636
3637       if Is_Private_Type (Typ) then
3638          Typ := Full_View (Typ);
3639       end if;
3640
3641       --  For a result of type integer, substitute an N_Integer_Literal node
3642       --  for the result of the compile time evaluation of the expression.
3643       --  For ASIS use, set a link to the original named number when not in
3644       --  a generic context.
3645
3646       if Is_Integer_Type (Typ) then
3647          Rewrite (N, Make_Integer_Literal (Loc, Val));
3648
3649          Set_Original_Entity (N, Ent);
3650
3651       --  Otherwise we have an enumeration type, and we substitute either
3652       --  an N_Identifier or N_Character_Literal to represent the enumeration
3653       --  literal corresponding to the given value, which must always be in
3654       --  range, because appropriate tests have already been made for this.
3655
3656       else pragma Assert (Is_Enumeration_Type (Typ));
3657          Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
3658       end if;
3659
3660       --  We now have the literal with the right value, both the actual type
3661       --  and the expected type of this literal are taken from the expression
3662       --  that was evaluated.
3663
3664       Analyze (N);
3665       Set_Is_Static_Expression (N, Static);
3666       Set_Etype (N, Typ);
3667       Resolve (N);
3668    end Fold_Uint;
3669
3670    ----------------
3671    -- Fold_Ureal --
3672    ----------------
3673
3674    procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
3675       Loc : constant Source_Ptr := Sloc (N);
3676       Typ : constant Entity_Id  := Etype (N);
3677       Ent : Entity_Id;
3678
3679    begin
3680       --  If we are folding a named number, retain the entity in the
3681       --  literal, for ASIS use.
3682
3683       if Is_Entity_Name (N)
3684         and then Ekind (Entity (N)) = E_Named_Real
3685       then
3686          Ent := Entity (N);
3687       else
3688          Ent := Empty;
3689       end if;
3690
3691       Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
3692
3693       --  Set link to original named number, for ASIS use
3694
3695       Set_Original_Entity (N, Ent);
3696
3697       --  Both the actual and expected type comes from the original expression
3698
3699       Analyze (N);
3700       Set_Is_Static_Expression (N, Static);
3701       Set_Etype (N, Typ);
3702       Resolve (N);
3703    end Fold_Ureal;
3704
3705    ---------------
3706    -- From_Bits --
3707    ---------------
3708
3709    function From_Bits (B : Bits; T : Entity_Id) return Uint is
3710       V : Uint := Uint_0;
3711
3712    begin
3713       for J in 0 .. B'Last loop
3714          if B (J) then
3715             V := V + 2 ** J;
3716          end if;
3717       end loop;
3718
3719       if Non_Binary_Modulus (T) then
3720          V := V mod Modulus (T);
3721       end if;
3722
3723       return V;
3724    end From_Bits;
3725
3726    --------------------
3727    -- Get_String_Val --
3728    --------------------
3729
3730    function Get_String_Val (N : Node_Id) return Node_Id is
3731    begin
3732       if Nkind (N) = N_String_Literal then
3733          return N;
3734
3735       elsif Nkind (N) = N_Character_Literal then
3736          return N;
3737
3738       else
3739          pragma Assert (Is_Entity_Name (N));
3740          return Get_String_Val (Constant_Value (Entity (N)));
3741       end if;
3742    end Get_String_Val;
3743
3744    ----------------
3745    -- Initialize --
3746    ----------------
3747
3748    procedure Initialize is
3749    begin
3750       CV_Cache := (others => (Node_High_Bound, Uint_0));
3751    end Initialize;
3752
3753    --------------------
3754    -- In_Subrange_Of --
3755    --------------------
3756
3757    function In_Subrange_Of
3758      (T1        : Entity_Id;
3759       T2        : Entity_Id;
3760       Fixed_Int : Boolean := False) return Boolean
3761    is
3762       L1 : Node_Id;
3763       H1 : Node_Id;
3764
3765       L2 : Node_Id;
3766       H2 : Node_Id;
3767
3768    begin
3769       if T1 = T2 or else Is_Subtype_Of (T1, T2) then
3770          return True;
3771
3772       --  Never in range if both types are not scalar. Don't know if this can
3773       --  actually happen, but just in case.
3774
3775       elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then
3776          return False;
3777
3778       --  If T1 has infinities but T2 doesn't have infinities, then T1 is
3779       --  definitely not compatible with T2.
3780
3781       elsif Is_Floating_Point_Type (T1)
3782         and then Has_Infinities (T1)
3783         and then Is_Floating_Point_Type (T2)
3784         and then not Has_Infinities (T2)
3785       then
3786          return False;
3787
3788       else
3789          L1 := Type_Low_Bound  (T1);
3790          H1 := Type_High_Bound (T1);
3791
3792          L2 := Type_Low_Bound  (T2);
3793          H2 := Type_High_Bound (T2);
3794
3795          --  Check bounds to see if comparison possible at compile time
3796
3797          if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE
3798               and then
3799             Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE
3800          then
3801             return True;
3802          end if;
3803
3804          --  If bounds not comparable at compile time, then the bounds of T2
3805          --  must be compile time known or we cannot answer the query.
3806
3807          if not Compile_Time_Known_Value (L2)
3808            or else not Compile_Time_Known_Value (H2)
3809          then
3810             return False;
3811          end if;
3812
3813          --  If the bounds of T1 are know at compile time then use these
3814          --  ones, otherwise use the bounds of the base type (which are of
3815          --  course always static).
3816
3817          if not Compile_Time_Known_Value (L1) then
3818             L1 := Type_Low_Bound (Base_Type (T1));
3819          end if;
3820
3821          if not Compile_Time_Known_Value (H1) then
3822             H1 := Type_High_Bound (Base_Type (T1));
3823          end if;
3824
3825          --  Fixed point types should be considered as such only if
3826          --  flag Fixed_Int is set to False.
3827
3828          if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
3829            or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
3830            or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
3831          then
3832             return
3833               Expr_Value_R (L2) <= Expr_Value_R (L1)
3834                 and then
3835               Expr_Value_R (H2) >= Expr_Value_R (H1);
3836
3837          else
3838             return
3839               Expr_Value (L2) <= Expr_Value (L1)
3840                 and then
3841               Expr_Value (H2) >= Expr_Value (H1);
3842
3843          end if;
3844       end if;
3845
3846    --  If any exception occurs, it means that we have some bug in the compiler
3847    --  possibly triggered by a previous error, or by some unforeseen peculiar
3848    --  occurrence. However, this is only an optimization attempt, so there is
3849    --  really no point in crashing the compiler. Instead we just decide, too
3850    --  bad, we can't figure out the answer in this case after all.
3851
3852    exception
3853       when others =>
3854
3855          --  Debug flag K disables this behavior (useful for debugging)
3856
3857          if Debug_Flag_K then
3858             raise;
3859          else
3860             return False;
3861          end if;
3862    end In_Subrange_Of;
3863
3864    -----------------
3865    -- Is_In_Range --
3866    -----------------
3867
3868    function Is_In_Range
3869      (N            : Node_Id;
3870       Typ          : Entity_Id;
3871       Assume_Valid : Boolean := False;
3872       Fixed_Int    : Boolean := False;
3873       Int_Real     : Boolean := False) return Boolean
3874    is
3875       Val  : Uint;
3876       Valr : Ureal;
3877
3878       pragma Warnings (Off, Assume_Valid);
3879       --  For now Assume_Valid is unreferenced since the current implementation
3880       --  always returns False if N is not a compile time known value, but we
3881       --  keep the parameter to allow for future enhancements in which we try
3882       --  to get the information in the variable case as well.
3883
3884    begin
3885       --  Universal types have no range limits, so always in range
3886
3887       if Typ = Universal_Integer or else Typ = Universal_Real then
3888          return True;
3889
3890       --  Never in range if not scalar type. Don't know if this can
3891       --  actually happen, but our spec allows it, so we must check!
3892
3893       elsif not Is_Scalar_Type (Typ) then
3894          return False;
3895
3896       --  Never in range unless we have a compile time known value
3897
3898       elsif not Compile_Time_Known_Value (N) then
3899          return False;
3900
3901       --  General processing with a known compile time value
3902
3903       else
3904          declare
3905             Lo       : Node_Id;
3906             Hi       : Node_Id;
3907             LB_Known : Boolean;
3908             UB_Known : Boolean;
3909
3910          begin
3911             Lo := Type_Low_Bound  (Typ);
3912             Hi := Type_High_Bound (Typ);
3913
3914             LB_Known := Compile_Time_Known_Value (Lo);
3915             UB_Known := Compile_Time_Known_Value (Hi);
3916
3917             --  Fixed point types should be considered as such only in
3918             --  flag Fixed_Int is set to False.
3919
3920             if Is_Floating_Point_Type (Typ)
3921               or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
3922               or else Int_Real
3923             then
3924                Valr := Expr_Value_R (N);
3925
3926                if LB_Known and then Valr >= Expr_Value_R (Lo)
3927                  and then UB_Known and then Valr <= Expr_Value_R (Hi)
3928                then
3929                   return True;
3930                else
3931                   return False;
3932                end if;
3933
3934             else
3935                Val := Expr_Value (N);
3936
3937                if         LB_Known and then Val >= Expr_Value (Lo)
3938                  and then UB_Known and then Val <= Expr_Value (Hi)
3939                then
3940                   return True;
3941                else
3942                   return False;
3943                end if;
3944             end if;
3945          end;
3946       end if;
3947    end Is_In_Range;
3948
3949    -------------------
3950    -- Is_Null_Range --
3951    -------------------
3952
3953    function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
3954       Typ : constant Entity_Id := Etype (Lo);
3955
3956    begin
3957       if not Compile_Time_Known_Value (Lo)
3958         or else not Compile_Time_Known_Value (Hi)
3959       then
3960          return False;
3961       end if;
3962
3963       if Is_Discrete_Type (Typ) then
3964          return Expr_Value (Lo) > Expr_Value (Hi);
3965
3966       else
3967          pragma Assert (Is_Real_Type (Typ));
3968          return Expr_Value_R (Lo) > Expr_Value_R (Hi);
3969       end if;
3970    end Is_Null_Range;
3971
3972    -----------------------------
3973    -- Is_OK_Static_Expression --
3974    -----------------------------
3975
3976    function Is_OK_Static_Expression (N : Node_Id) return Boolean is
3977    begin
3978       return Is_Static_Expression (N)
3979         and then not Raises_Constraint_Error (N);
3980    end Is_OK_Static_Expression;
3981
3982    ------------------------
3983    -- Is_OK_Static_Range --
3984    ------------------------
3985
3986    --  A static range is a range whose bounds are static expressions, or a
3987    --  Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3988    --  We have already converted range attribute references, so we get the
3989    --  "or" part of this rule without needing a special test.
3990
3991    function Is_OK_Static_Range (N : Node_Id) return Boolean is
3992    begin
3993       return Is_OK_Static_Expression (Low_Bound (N))
3994         and then Is_OK_Static_Expression (High_Bound (N));
3995    end Is_OK_Static_Range;
3996
3997    --------------------------
3998    -- Is_OK_Static_Subtype --
3999    --------------------------
4000
4001    --  Determines if Typ is a static subtype as defined in (RM 4.9(26))
4002    --  where neither bound raises constraint error when evaluated.
4003
4004    function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
4005       Base_T   : constant Entity_Id := Base_Type (Typ);
4006       Anc_Subt : Entity_Id;
4007
4008    begin
4009       --  First a quick check on the non static subtype flag. As described
4010       --  in further detail in Einfo, this flag is not decisive in all cases,
4011       --  but if it is set, then the subtype is definitely non-static.
4012
4013       if Is_Non_Static_Subtype (Typ) then
4014          return False;
4015       end if;
4016
4017       Anc_Subt := Ancestor_Subtype (Typ);
4018
4019       if Anc_Subt = Empty then
4020          Anc_Subt := Base_T;
4021       end if;
4022
4023       if Is_Generic_Type (Root_Type (Base_T))
4024         or else Is_Generic_Actual_Type (Base_T)
4025       then
4026          return False;
4027
4028       --  String types
4029
4030       elsif Is_String_Type (Typ) then
4031          return
4032            Ekind (Typ) = E_String_Literal_Subtype
4033              or else
4034            (Is_OK_Static_Subtype (Component_Type (Typ))
4035               and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
4036
4037       --  Scalar types
4038
4039       elsif Is_Scalar_Type (Typ) then
4040          if Base_T = Typ then
4041             return True;
4042
4043          else
4044             --  Scalar_Range (Typ) might be an N_Subtype_Indication, so
4045             --  use Get_Type_Low,High_Bound.
4046
4047             return     Is_OK_Static_Subtype (Anc_Subt)
4048               and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
4049               and then Is_OK_Static_Expression (Type_High_Bound (Typ));
4050          end if;
4051
4052       --  Types other than string and scalar types are never static
4053
4054       else
4055          return False;
4056       end if;
4057    end Is_OK_Static_Subtype;
4058
4059    ---------------------
4060    -- Is_Out_Of_Range --
4061    ---------------------
4062
4063    function Is_Out_Of_Range
4064      (N            : Node_Id;
4065       Typ          : Entity_Id;
4066       Assume_Valid : Boolean := False;
4067       Fixed_Int    : Boolean := False;
4068       Int_Real     : Boolean := False) return Boolean
4069    is
4070       Val  : Uint;
4071       Valr : Ureal;
4072
4073       pragma Warnings (Off, Assume_Valid);
4074       --  For now Assume_Valid is unreferenced since the current implementation
4075       --  always returns False if N is not a compile time known value, but we
4076       --  keep the parameter to allow for future enhancements in which we try
4077       --  to get the information in the variable case as well.
4078
4079    begin
4080       --  Universal types have no range limits, so always in range
4081
4082       if Typ = Universal_Integer or else Typ = Universal_Real then
4083          return False;
4084
4085       --  Never out of range if not scalar type. Don't know if this can
4086       --  actually happen, but our spec allows it, so we must check!
4087
4088       elsif not Is_Scalar_Type (Typ) then
4089          return False;
4090
4091       --  Never out of range if this is a generic type, since the bounds
4092       --  of generic types are junk. Note that if we only checked for
4093       --  static expressions (instead of compile time known values) below,
4094       --  we would not need this check, because values of a generic type
4095       --  can never be static, but they can be known at compile time.
4096
4097       elsif Is_Generic_Type (Typ) then
4098          return False;
4099
4100       --  Never out of range unless we have a compile time known value
4101
4102       elsif not Compile_Time_Known_Value (N) then
4103          return False;
4104
4105       else
4106          declare
4107             Lo       : Node_Id;
4108             Hi       : Node_Id;
4109             LB_Known : Boolean;
4110             UB_Known : Boolean;
4111
4112          begin
4113             Lo := Type_Low_Bound (Typ);
4114             Hi := Type_High_Bound (Typ);
4115
4116             LB_Known := Compile_Time_Known_Value (Lo);
4117             UB_Known := Compile_Time_Known_Value (Hi);
4118
4119             --  Real types (note that fixed-point types are not treated
4120             --  as being of a real type if the flag Fixed_Int is set,
4121             --  since in that case they are regarded as integer types).
4122
4123             if Is_Floating_Point_Type (Typ)
4124               or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
4125               or else Int_Real
4126             then
4127                Valr := Expr_Value_R (N);
4128
4129                if LB_Known and then Valr < Expr_Value_R (Lo) then
4130                   return True;
4131
4132                elsif UB_Known and then Expr_Value_R (Hi) < Valr then
4133                   return True;
4134
4135                else
4136                   return False;
4137                end if;
4138
4139             else
4140                Val := Expr_Value (N);
4141
4142                if LB_Known and then Val < Expr_Value (Lo) then
4143                   return True;
4144
4145                elsif UB_Known and then Expr_Value (Hi) < Val then
4146                   return True;
4147
4148                else
4149                   return False;
4150                end if;
4151             end if;
4152          end;
4153       end if;
4154    end Is_Out_Of_Range;
4155
4156    ---------------------
4157    -- Is_Static_Range --
4158    ---------------------
4159
4160    --  A static range is a range whose bounds are static expressions, or a
4161    --  Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4162    --  We have already converted range attribute references, so we get the
4163    --  "or" part of this rule without needing a special test.
4164
4165    function Is_Static_Range (N : Node_Id) return Boolean is
4166    begin
4167       return Is_Static_Expression (Low_Bound (N))
4168         and then Is_Static_Expression (High_Bound (N));
4169    end Is_Static_Range;
4170
4171    -----------------------
4172    -- Is_Static_Subtype --
4173    -----------------------
4174
4175    --  Determines if Typ is a static subtype as defined in (RM 4.9(26))
4176
4177    function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
4178       Base_T   : constant Entity_Id := Base_Type (Typ);
4179       Anc_Subt : Entity_Id;
4180
4181    begin
4182       --  First a quick check on the non static subtype flag. As described
4183       --  in further detail in Einfo, this flag is not decisive in all cases,
4184       --  but if it is set, then the subtype is definitely non-static.
4185
4186       if Is_Non_Static_Subtype (Typ) then
4187          return False;
4188       end if;
4189
4190       Anc_Subt := Ancestor_Subtype (Typ);
4191
4192       if Anc_Subt = Empty then
4193          Anc_Subt := Base_T;
4194       end if;
4195
4196       if Is_Generic_Type (Root_Type (Base_T))
4197         or else Is_Generic_Actual_Type (Base_T)
4198       then
4199          return False;
4200
4201       --  String types
4202
4203       elsif Is_String_Type (Typ) then
4204          return
4205            Ekind (Typ) = E_String_Literal_Subtype
4206              or else
4207            (Is_Static_Subtype (Component_Type (Typ))
4208               and then Is_Static_Subtype (Etype (First_Index (Typ))));
4209
4210       --  Scalar types
4211
4212       elsif Is_Scalar_Type (Typ) then
4213          if Base_T = Typ then
4214             return True;
4215
4216          else
4217             return     Is_Static_Subtype (Anc_Subt)
4218               and then Is_Static_Expression (Type_Low_Bound (Typ))
4219               and then Is_Static_Expression (Type_High_Bound (Typ));
4220          end if;
4221
4222       --  Types other than string and scalar types are never static
4223
4224       else
4225          return False;
4226       end if;
4227    end Is_Static_Subtype;
4228
4229    --------------------
4230    -- Not_Null_Range --
4231    --------------------
4232
4233    function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
4234       Typ : constant Entity_Id := Etype (Lo);
4235
4236    begin
4237       if not Compile_Time_Known_Value (Lo)
4238         or else not Compile_Time_Known_Value (Hi)
4239       then
4240          return False;
4241       end if;
4242
4243       if Is_Discrete_Type (Typ) then
4244          return Expr_Value (Lo) <= Expr_Value (Hi);
4245
4246       else
4247          pragma Assert (Is_Real_Type (Typ));
4248
4249          return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
4250       end if;
4251    end Not_Null_Range;
4252
4253    -------------
4254    -- OK_Bits --
4255    -------------
4256
4257    function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
4258    begin
4259       --  We allow a maximum of 500,000 bits which seems a reasonable limit
4260
4261       if Bits < 500_000 then
4262          return True;
4263
4264       else
4265          Error_Msg_N ("static value too large, capacity exceeded", N);
4266          return False;
4267       end if;
4268    end OK_Bits;
4269
4270    ------------------
4271    -- Out_Of_Range --
4272    ------------------
4273
4274    procedure Out_Of_Range (N : Node_Id) is
4275    begin
4276       --  If we have the static expression case, then this is an illegality
4277       --  in Ada 95 mode, except that in an instance, we never generate an
4278       --  error (if the error is legitimate, it was already diagnosed in
4279       --  the template). The expression to compute the length of a packed
4280       --  array is attached to the array type itself, and deserves a separate
4281       --  message.
4282
4283       if Is_Static_Expression (N)
4284         and then not In_Instance
4285         and then not In_Inlined_Body
4286         and then Ada_Version >= Ada_95
4287       then
4288          if Nkind (Parent (N)) = N_Defining_Identifier
4289            and then Is_Array_Type (Parent (N))
4290            and then Present (Packed_Array_Type (Parent (N)))
4291            and then Present (First_Rep_Item (Parent (N)))
4292          then
4293             Error_Msg_N
4294              ("length of packed array must not exceed Integer''Last",
4295               First_Rep_Item (Parent (N)));
4296             Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
4297
4298          else
4299             Apply_Compile_Time_Constraint_Error
4300               (N, "value not in range of}", CE_Range_Check_Failed);
4301          end if;
4302
4303       --  Here we generate a warning for the Ada 83 case, or when we are
4304       --  in an instance, or when we have a non-static expression case.
4305
4306       else
4307          Apply_Compile_Time_Constraint_Error
4308            (N, "value not in range of}?", CE_Range_Check_Failed);
4309       end if;
4310    end Out_Of_Range;
4311
4312    -------------------------
4313    -- Rewrite_In_Raise_CE --
4314    -------------------------
4315
4316    procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
4317       Typ : constant Entity_Id := Etype (N);
4318
4319    begin
4320       --  If we want to raise CE in the condition of a raise_CE node
4321       --  we may as well get rid of the condition
4322
4323       if Present (Parent (N))
4324         and then Nkind (Parent (N)) = N_Raise_Constraint_Error
4325       then
4326          Set_Condition (Parent (N), Empty);
4327
4328       --  If the expression raising CE is a N_Raise_CE node, we can use
4329       --  that one. We just preserve the type of the context
4330
4331       elsif Nkind (Exp) = N_Raise_Constraint_Error then
4332          Rewrite (N, Exp);
4333          Set_Etype (N, Typ);
4334
4335       --  We have to build an explicit raise_ce node
4336
4337       else
4338          Rewrite (N,
4339            Make_Raise_Constraint_Error (Sloc (Exp),
4340              Reason => CE_Range_Check_Failed));
4341          Set_Raises_Constraint_Error (N);
4342          Set_Etype (N, Typ);
4343       end if;
4344    end Rewrite_In_Raise_CE;
4345
4346    ---------------------
4347    -- String_Type_Len --
4348    ---------------------
4349
4350    function String_Type_Len (Stype : Entity_Id) return Uint is
4351       NT : constant Entity_Id := Etype (First_Index (Stype));
4352       T  : Entity_Id;
4353
4354    begin
4355       if Is_OK_Static_Subtype (NT) then
4356          T := NT;
4357       else
4358          T := Base_Type (NT);
4359       end if;
4360
4361       return Expr_Value (Type_High_Bound (T)) -
4362              Expr_Value (Type_Low_Bound (T)) + 1;
4363    end String_Type_Len;
4364
4365    ------------------------------------
4366    -- Subtypes_Statically_Compatible --
4367    ------------------------------------
4368
4369    function Subtypes_Statically_Compatible
4370      (T1 : Entity_Id;
4371       T2 : Entity_Id) return Boolean
4372    is
4373    begin
4374       if Is_Scalar_Type (T1) then
4375
4376          --  Definitely compatible if we match
4377
4378          if Subtypes_Statically_Match (T1, T2) then
4379             return True;
4380
4381          --  If either subtype is nonstatic then they're not compatible
4382
4383          elsif not Is_Static_Subtype (T1)
4384            or else not Is_Static_Subtype (T2)
4385          then
4386             return False;
4387
4388          --  If either type has constraint error bounds, then consider that
4389          --  they match to avoid junk cascaded errors here.
4390
4391          elsif not Is_OK_Static_Subtype (T1)
4392            or else not Is_OK_Static_Subtype (T2)
4393          then
4394             return True;
4395
4396          --  Base types must match, but we don't check that (should
4397          --  we???) but we do at least check that both types are
4398          --  real, or both types are not real.
4399
4400          elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
4401             return False;
4402
4403          --  Here we check the bounds
4404
4405          else
4406             declare
4407                LB1 : constant Node_Id := Type_Low_Bound  (T1);
4408                HB1 : constant Node_Id := Type_High_Bound (T1);
4409                LB2 : constant Node_Id := Type_Low_Bound  (T2);
4410                HB2 : constant Node_Id := Type_High_Bound (T2);
4411
4412             begin
4413                if Is_Real_Type (T1) then
4414                   return
4415                     (Expr_Value_R (LB1) > Expr_Value_R (HB1))
4416                       or else
4417                     (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
4418                        and then
4419                      Expr_Value_R (HB1) <= Expr_Value_R (HB2));
4420
4421                else
4422                   return
4423                     (Expr_Value (LB1) > Expr_Value (HB1))
4424                       or else
4425                     (Expr_Value (LB2) <= Expr_Value (LB1)
4426                        and then
4427                      Expr_Value (HB1) <= Expr_Value (HB2));
4428                end if;
4429             end;
4430          end if;
4431
4432       elsif Is_Access_Type (T1) then
4433          return not Is_Constrained (T2)
4434            or else Subtypes_Statically_Match
4435                      (Designated_Type (T1), Designated_Type (T2));
4436
4437       else
4438          return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
4439            or else Subtypes_Statically_Match (T1, T2);
4440       end if;
4441    end Subtypes_Statically_Compatible;
4442
4443    -------------------------------
4444    -- Subtypes_Statically_Match --
4445    -------------------------------
4446
4447    --  Subtypes statically match if they have statically matching constraints
4448    --  (RM 4.9.1(2)). Constraints statically match if there are none, or if
4449    --  they are the same identical constraint, or if they are static and the
4450    --  values match (RM 4.9.1(1)).
4451
4452    function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is
4453    begin
4454       --  A type always statically matches itself
4455
4456       if T1 = T2 then
4457          return True;
4458
4459       --  Scalar types
4460
4461       elsif Is_Scalar_Type (T1) then
4462
4463          --  Base types must be the same
4464
4465          if Base_Type (T1) /= Base_Type (T2) then
4466             return False;
4467          end if;
4468
4469          --  A constrained numeric subtype never matches an unconstrained
4470          --  subtype, i.e. both types must be constrained or unconstrained.
4471
4472          --  To understand the requirement for this test, see RM 4.9.1(1).
4473          --  As is made clear in RM 3.5.4(11), type Integer, for example
4474          --  is a constrained subtype with constraint bounds matching the
4475          --  bounds of its corresponding unconstrained base type. In this
4476          --  situation, Integer and Integer'Base do not statically match,
4477          --  even though they have the same bounds.
4478
4479          --  We only apply this test to types in Standard and types that
4480          --  appear in user programs. That way, we do not have to be
4481          --  too careful about setting Is_Constrained right for itypes.
4482
4483          if Is_Numeric_Type (T1)
4484            and then (Is_Constrained (T1) /= Is_Constrained (T2))
4485            and then (Scope (T1) = Standard_Standard
4486                       or else Comes_From_Source (T1))
4487            and then (Scope (T2) = Standard_Standard
4488                       or else Comes_From_Source (T2))
4489          then
4490             return False;
4491
4492          --  A generic scalar type does not statically match its base
4493          --  type (AI-311). In this case we make sure that the formals,
4494          --  which are first subtypes of their bases, are constrained.
4495
4496          elsif Is_Generic_Type (T1)
4497            and then Is_Generic_Type (T2)
4498            and then (Is_Constrained (T1) /= Is_Constrained (T2))
4499          then
4500             return False;
4501          end if;
4502
4503          --  If there was an error in either range, then just assume
4504          --  the types statically match to avoid further junk errors
4505
4506          if Error_Posted (Scalar_Range (T1))
4507               or else
4508             Error_Posted (Scalar_Range (T2))
4509          then
4510             return True;
4511          end if;
4512
4513          --  Otherwise both types have bound that can be compared
4514
4515          declare
4516             LB1 : constant Node_Id := Type_Low_Bound  (T1);
4517             HB1 : constant Node_Id := Type_High_Bound (T1);
4518             LB2 : constant Node_Id := Type_Low_Bound  (T2);
4519             HB2 : constant Node_Id := Type_High_Bound (T2);
4520
4521          begin
4522             --  If the bounds are the same tree node, then match
4523
4524             if LB1 = LB2 and then HB1 = HB2 then
4525                return True;
4526
4527             --  Otherwise bounds must be static and identical value
4528
4529             else
4530                if not Is_Static_Subtype (T1)
4531                  or else not Is_Static_Subtype (T2)
4532                then
4533                   return False;
4534
4535                --  If either type has constraint error bounds, then say
4536                --  that they match to avoid junk cascaded errors here.
4537
4538                elsif not Is_OK_Static_Subtype (T1)
4539                  or else not Is_OK_Static_Subtype (T2)
4540                then
4541                   return True;
4542
4543                elsif Is_Real_Type (T1) then
4544                   return
4545                     (Expr_Value_R (LB1) = Expr_Value_R (LB2))
4546                       and then
4547                     (Expr_Value_R (HB1) = Expr_Value_R (HB2));
4548
4549                else
4550                   return
4551                     Expr_Value (LB1) = Expr_Value (LB2)
4552                       and then
4553                     Expr_Value (HB1) = Expr_Value (HB2);
4554                end if;
4555             end if;
4556          end;
4557
4558       --  Type with discriminants
4559
4560       elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
4561
4562          --  Because of view exchanges in multiple instantiations, conformance
4563          --  checking might try to match a partial view of a type with no
4564          --  discriminants with a full view that has defaulted discriminants.
4565          --  In such a case, use the discriminant constraint of the full view,
4566          --  which must exist because we know that the two subtypes have the
4567          --  same base type.
4568
4569          if Has_Discriminants (T1) /= Has_Discriminants (T2) then
4570             if In_Instance then
4571                if Is_Private_Type (T2)
4572                  and then Present (Full_View (T2))
4573                  and then Has_Discriminants (Full_View (T2))
4574                then
4575                   return Subtypes_Statically_Match (T1, Full_View (T2));
4576
4577                elsif Is_Private_Type (T1)
4578                  and then Present (Full_View (T1))
4579                  and then Has_Discriminants (Full_View (T1))
4580                then
4581                   return Subtypes_Statically_Match (Full_View (T1), T2);
4582
4583                else
4584                   return False;
4585                end if;
4586             else
4587                return False;
4588             end if;
4589          end if;
4590
4591          declare
4592             DL1 : constant Elist_Id := Discriminant_Constraint (T1);
4593             DL2 : constant Elist_Id := Discriminant_Constraint (T2);
4594
4595             DA1 : Elmt_Id;
4596             DA2 : Elmt_Id;
4597
4598          begin
4599             if DL1 = DL2 then
4600                return True;
4601             elsif Is_Constrained (T1) /= Is_Constrained (T2) then
4602                return False;
4603             end if;
4604
4605             --  Now loop through the discriminant constraints
4606
4607             --  Note: the guard here seems necessary, since it is possible at
4608             --  least for DL1 to be No_Elist. Not clear this is reasonable ???
4609
4610             if Present (DL1) and then Present (DL2) then
4611                DA1 := First_Elmt (DL1);
4612                DA2 := First_Elmt (DL2);
4613                while Present (DA1) loop
4614                   declare
4615                      Expr1 : constant Node_Id := Node (DA1);
4616                      Expr2 : constant Node_Id := Node (DA2);
4617
4618                   begin
4619                      if not Is_Static_Expression (Expr1)
4620                        or else not Is_Static_Expression (Expr2)
4621                      then
4622                         return False;
4623
4624                         --  If either expression raised a constraint error,
4625                         --  consider the expressions as matching, since this
4626                         --  helps to prevent cascading errors.
4627
4628                      elsif Raises_Constraint_Error (Expr1)
4629                        or else Raises_Constraint_Error (Expr2)
4630                      then
4631                         null;
4632
4633                      elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
4634                         return False;
4635                      end if;
4636                   end;
4637
4638                   Next_Elmt (DA1);
4639                   Next_Elmt (DA2);
4640                end loop;
4641             end if;
4642          end;
4643
4644          return True;
4645
4646       --  A definite type does not match an indefinite or classwide type
4647       --  However, a generic type with unknown discriminants may be
4648       --  instantiated with a type with no discriminants, and conformance
4649       --  checking on an inherited operation may compare the actual with
4650       --  the subtype that renames it in the instance.
4651
4652       elsif
4653          Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
4654       then
4655          return
4656            Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2);
4657
4658       --  Array type
4659
4660       elsif Is_Array_Type (T1) then
4661
4662          --  If either subtype is unconstrained then both must be,
4663          --  and if both are unconstrained then no further checking
4664          --  is needed.
4665
4666          if not Is_Constrained (T1) or else not Is_Constrained (T2) then
4667             return not (Is_Constrained (T1) or else Is_Constrained (T2));
4668          end if;
4669
4670          --  Both subtypes are constrained, so check that the index
4671          --  subtypes statically match.
4672
4673          declare
4674             Index1 : Node_Id := First_Index (T1);
4675             Index2 : Node_Id := First_Index (T2);
4676
4677          begin
4678             while Present (Index1) loop
4679                if not
4680                  Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
4681                then
4682                   return False;
4683                end if;
4684
4685                Next_Index (Index1);
4686                Next_Index (Index2);
4687             end loop;
4688
4689             return True;
4690          end;
4691
4692       elsif Is_Access_Type (T1) then
4693          if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
4694             return False;
4695
4696          elsif Ekind (T1) = E_Access_Subprogram_Type
4697            or else Ekind (T1) = E_Anonymous_Access_Subprogram_Type
4698          then
4699             return
4700               Subtype_Conformant
4701                 (Designated_Type (T1),
4702                  Designated_Type (T2));
4703          else
4704             return
4705               Subtypes_Statically_Match
4706                 (Designated_Type (T1),
4707                  Designated_Type (T2))
4708               and then Is_Access_Constant (T1) = Is_Access_Constant (T2);
4709          end if;
4710
4711       --  All other types definitely match
4712
4713       else
4714          return True;
4715       end if;
4716    end Subtypes_Statically_Match;
4717
4718    ----------
4719    -- Test --
4720    ----------
4721
4722    function Test (Cond : Boolean) return Uint is
4723    begin
4724       if Cond then
4725          return Uint_1;
4726       else
4727          return Uint_0;
4728       end if;
4729    end Test;
4730
4731    ---------------------------------
4732    -- Test_Expression_Is_Foldable --
4733    ---------------------------------
4734
4735    --  One operand case
4736
4737    procedure Test_Expression_Is_Foldable
4738      (N    : Node_Id;
4739       Op1  : Node_Id;
4740       Stat : out Boolean;
4741       Fold : out Boolean)
4742    is
4743    begin
4744       Stat := False;
4745       Fold := False;
4746
4747       if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
4748          return;
4749       end if;
4750
4751       --  If operand is Any_Type, just propagate to result and do not
4752       --  try to fold, this prevents cascaded errors.
4753
4754       if Etype (Op1) = Any_Type then
4755          Set_Etype (N, Any_Type);
4756          return;
4757
4758       --  If operand raises constraint error, then replace node N with the
4759       --  raise constraint error node, and we are obviously not foldable.
4760       --  Note that this replacement inherits the Is_Static_Expression flag
4761       --  from the operand.
4762
4763       elsif Raises_Constraint_Error (Op1) then
4764          Rewrite_In_Raise_CE (N, Op1);
4765          return;
4766
4767       --  If the operand is not static, then the result is not static, and
4768       --  all we have to do is to check the operand since it is now known
4769       --  to appear in a non-static context.
4770
4771       elsif not Is_Static_Expression (Op1) then
4772          Check_Non_Static_Context (Op1);
4773          Fold := Compile_Time_Known_Value (Op1);
4774          return;
4775
4776       --   An expression of a formal modular type is not foldable because
4777       --   the modulus is unknown.
4778
4779       elsif Is_Modular_Integer_Type (Etype (Op1))
4780         and then Is_Generic_Type (Etype (Op1))
4781       then
4782          Check_Non_Static_Context (Op1);
4783          return;
4784
4785       --  Here we have the case of an operand whose type is OK, which is
4786       --  static, and which does not raise constraint error, we can fold.
4787
4788       else
4789          Set_Is_Static_Expression (N);
4790          Fold := True;
4791          Stat := True;
4792       end if;
4793    end Test_Expression_Is_Foldable;
4794
4795    --  Two operand case
4796
4797    procedure Test_Expression_Is_Foldable
4798      (N    : Node_Id;
4799       Op1  : Node_Id;
4800       Op2  : Node_Id;
4801       Stat : out Boolean;
4802       Fold : out Boolean)
4803    is
4804       Rstat : constant Boolean := Is_Static_Expression (Op1)
4805                                     and then Is_Static_Expression (Op2);
4806
4807    begin
4808       Stat := False;
4809       Fold := False;
4810
4811       if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
4812          return;
4813       end if;
4814
4815       --  If either operand is Any_Type, just propagate to result and
4816       --  do not try to fold, this prevents cascaded errors.
4817
4818       if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
4819          Set_Etype (N, Any_Type);
4820          return;
4821
4822       --  If left operand raises constraint error, then replace node N with
4823       --  the raise constraint error node, and we are obviously not foldable.
4824       --  Is_Static_Expression is set from the two operands in the normal way,
4825       --  and we check the right operand if it is in a non-static context.
4826
4827       elsif Raises_Constraint_Error (Op1) then
4828          if not Rstat then
4829             Check_Non_Static_Context (Op2);
4830          end if;
4831
4832          Rewrite_In_Raise_CE (N, Op1);
4833          Set_Is_Static_Expression (N, Rstat);
4834          return;
4835
4836       --  Similar processing for the case of the right operand. Note that
4837       --  we don't use this routine for the short-circuit case, so we do
4838       --  not have to worry about that special case here.
4839
4840       elsif Raises_Constraint_Error (Op2) then
4841          if not Rstat then
4842             Check_Non_Static_Context (Op1);
4843          end if;
4844
4845          Rewrite_In_Raise_CE (N, Op2);
4846          Set_Is_Static_Expression (N, Rstat);
4847          return;
4848
4849       --  Exclude expressions of a generic modular type, as above
4850
4851       elsif Is_Modular_Integer_Type (Etype (Op1))
4852         and then Is_Generic_Type (Etype (Op1))
4853       then
4854          Check_Non_Static_Context (Op1);
4855          return;
4856
4857       --  If result is not static, then check non-static contexts on operands
4858       --  since one of them may be static and the other one may not be static
4859
4860       elsif not Rstat then
4861          Check_Non_Static_Context (Op1);
4862          Check_Non_Static_Context (Op2);
4863          Fold := Compile_Time_Known_Value (Op1)
4864                    and then Compile_Time_Known_Value (Op2);
4865          return;
4866
4867       --  Else result is static and foldable. Both operands are static,
4868       --  and neither raises constraint error, so we can definitely fold.
4869
4870       else
4871          Set_Is_Static_Expression (N);
4872          Fold := True;
4873          Stat := True;
4874          return;
4875       end if;
4876    end Test_Expression_Is_Foldable;
4877
4878    --------------
4879    -- To_Bits --
4880    --------------
4881
4882    procedure To_Bits (U : Uint; B : out Bits) is
4883    begin
4884       for J in 0 .. B'Last loop
4885          B (J) := (U / (2 ** J)) mod 2 /= 0;
4886       end loop;
4887    end To_Bits;
4888
4889    --------------------
4890    -- Why_Not_Static --
4891    --------------------
4892
4893    procedure Why_Not_Static (Expr : Node_Id) is
4894       N   : constant Node_Id   := Original_Node (Expr);
4895       Typ : Entity_Id;
4896       E   : Entity_Id;
4897
4898       procedure Why_Not_Static_List (L : List_Id);
4899       --  A version that can be called on a list of expressions. Finds
4900       --  all non-static violations in any element of the list.
4901
4902       -------------------------
4903       -- Why_Not_Static_List --
4904       -------------------------
4905
4906       procedure Why_Not_Static_List (L : List_Id) is
4907          N : Node_Id;
4908
4909       begin
4910          if Is_Non_Empty_List (L) then
4911             N := First (L);
4912             while Present (N) loop
4913                Why_Not_Static (N);
4914                Next (N);
4915             end loop;
4916          end if;
4917       end Why_Not_Static_List;
4918
4919    --  Start of processing for Why_Not_Static
4920
4921    begin
4922       --  If in ACATS mode (debug flag 2), then suppress all these
4923       --  messages, this avoids massive updates to the ACATS base line.
4924
4925       if Debug_Flag_2 then
4926          return;
4927       end if;
4928
4929       --  Ignore call on error or empty node
4930
4931       if No (Expr) or else Nkind (Expr) = N_Error then
4932          return;
4933       end if;
4934
4935       --  Preprocessing for sub expressions
4936
4937       if Nkind (Expr) in N_Subexpr then
4938
4939          --  Nothing to do if expression is static
4940
4941          if Is_OK_Static_Expression (Expr) then
4942             return;
4943          end if;
4944
4945          --  Test for constraint error raised
4946
4947          if Raises_Constraint_Error (Expr) then
4948             Error_Msg_N
4949               ("expression raises exception, cannot be static " &
4950                "(RM 4.9(34))!", N);
4951             return;
4952          end if;
4953
4954          --  If no type, then something is pretty wrong, so ignore
4955
4956          Typ := Etype (Expr);
4957
4958          if No (Typ) then
4959             return;
4960          end if;
4961
4962          --  Type must be scalar or string type
4963
4964          if not Is_Scalar_Type (Typ)
4965            and then not Is_String_Type (Typ)
4966          then
4967             Error_Msg_N
4968               ("static expression must have scalar or string type " &
4969                "(RM 4.9(2))!", N);
4970             return;
4971          end if;
4972       end if;
4973
4974       --  If we got through those checks, test particular node kind
4975
4976       case Nkind (N) is
4977          when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
4978             E := Entity (N);
4979
4980             if Is_Named_Number (E) then
4981                null;
4982
4983             elsif Ekind (E) = E_Constant then
4984                if not Is_Static_Expression (Constant_Value (E)) then
4985                   Error_Msg_NE
4986                     ("& is not a static constant (RM 4.9(5))!", N, E);
4987                end if;
4988
4989             else
4990                Error_Msg_NE
4991                  ("& is not static constant or named number " &
4992                   "(RM 4.9(5))!", N, E);
4993             end if;
4994
4995          when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
4996             if Nkind (N) in N_Op_Shift then
4997                Error_Msg_N
4998                 ("shift functions are never static (RM 4.9(6,18))!", N);
4999
5000             else
5001                Why_Not_Static (Left_Opnd (N));
5002                Why_Not_Static (Right_Opnd (N));
5003             end if;
5004
5005          when N_Unary_Op =>
5006             Why_Not_Static (Right_Opnd (N));
5007
5008          when N_Attribute_Reference =>
5009             Why_Not_Static_List (Expressions (N));
5010
5011             E := Etype (Prefix (N));
5012
5013             if E = Standard_Void_Type then
5014                return;
5015             end if;
5016
5017             --  Special case non-scalar'Size since this is a common error
5018
5019             if Attribute_Name (N) = Name_Size then
5020                Error_Msg_N
5021                  ("size attribute is only static for scalar type " &
5022                   "(RM 4.9(7,8))", N);
5023
5024             --  Flag array cases
5025
5026             elsif Is_Array_Type (E) then
5027                if Attribute_Name (N) /= Name_First
5028                     and then
5029                   Attribute_Name (N) /= Name_Last
5030                     and then
5031                   Attribute_Name (N) /= Name_Length
5032                then
5033                   Error_Msg_N
5034                     ("static array attribute must be Length, First, or Last " &
5035                      "(RM 4.9(8))!", N);
5036
5037                --  Since we know the expression is not-static (we already
5038                --  tested for this, must mean array is not static).
5039
5040                else
5041                   Error_Msg_N
5042                     ("prefix is non-static array (RM 4.9(8))!", Prefix (N));
5043                end if;
5044
5045                return;
5046
5047             --  Special case generic types, since again this is a common
5048             --  source of confusion.
5049
5050             elsif Is_Generic_Actual_Type (E)
5051                     or else
5052                   Is_Generic_Type (E)
5053             then
5054                Error_Msg_N
5055                  ("attribute of generic type is never static " &
5056                   "(RM 4.9(7,8))!", N);
5057
5058             elsif Is_Static_Subtype (E) then
5059                null;
5060
5061             elsif Is_Scalar_Type (E) then
5062                Error_Msg_N
5063                  ("prefix type for attribute is not static scalar subtype " &
5064                   "(RM 4.9(7))!", N);
5065
5066             else
5067                Error_Msg_N
5068                  ("static attribute must apply to array/scalar type " &
5069                   "(RM 4.9(7,8))!", N);
5070             end if;
5071
5072          when N_String_Literal =>
5073             Error_Msg_N
5074               ("subtype of string literal is non-static (RM 4.9(4))!", N);
5075
5076          when N_Explicit_Dereference =>
5077             Error_Msg_N
5078               ("explicit dereference is never static (RM 4.9)!", N);
5079
5080          when N_Function_Call =>
5081             Why_Not_Static_List (Parameter_Associations (N));
5082             Error_Msg_N ("non-static function call (RM 4.9(6,18))!", N);
5083
5084          when N_Parameter_Association =>
5085             Why_Not_Static (Explicit_Actual_Parameter (N));
5086
5087          when N_Indexed_Component =>
5088             Error_Msg_N
5089               ("indexed component is never static (RM 4.9)!", N);
5090
5091          when N_Procedure_Call_Statement =>
5092             Error_Msg_N
5093               ("procedure call is never static (RM 4.9)!", N);
5094
5095          when N_Qualified_Expression =>
5096             Why_Not_Static (Expression (N));
5097
5098          when N_Aggregate | N_Extension_Aggregate =>
5099             Error_Msg_N
5100               ("an aggregate is never static (RM 4.9)!", N);
5101
5102          when N_Range =>
5103             Why_Not_Static (Low_Bound (N));
5104             Why_Not_Static (High_Bound (N));
5105
5106          when N_Range_Constraint =>
5107             Why_Not_Static (Range_Expression (N));
5108
5109          when N_Subtype_Indication =>
5110             Why_Not_Static (Constraint (N));
5111
5112          when N_Selected_Component =>
5113             Error_Msg_N
5114               ("selected component is never static (RM 4.9)!", N);
5115
5116          when N_Slice =>
5117             Error_Msg_N
5118               ("slice is never static (RM 4.9)!", N);
5119
5120          when N_Type_Conversion =>
5121             Why_Not_Static (Expression (N));
5122
5123             if not Is_Scalar_Type (Etype (Prefix (N)))
5124               or else not Is_Static_Subtype (Etype (Prefix (N)))
5125             then
5126                Error_Msg_N
5127                  ("static conversion requires static scalar subtype result " &
5128                   "(RM 4.9(9))!", N);
5129             end if;
5130
5131          when N_Unchecked_Type_Conversion =>
5132             Error_Msg_N
5133               ("unchecked type conversion is never static (RM 4.9)!", N);
5134
5135          when others =>
5136             null;
5137
5138       end case;
5139    end Why_Not_Static;
5140
5141 end Sem_Eval;