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