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