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