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