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 immediately 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
2682       --  A slice of the form  A (subtype), when the subtype is the index of
2683       --  the type of A, is redundant, the slice can be replaced with A, and
2684       --  this is worth a warning.
2685
2686       if Is_Entity_Name (Prefix (N)) then
2687          declare
2688             E : constant Entity_Id := Entity (Prefix (N));
2689             T : constant Entity_Id := Etype (E);
2690          begin
2691             if Ekind (E) = E_Constant
2692               and then Is_Array_Type (T)
2693               and then Is_Entity_Name (Drange)
2694             then
2695                if Is_Entity_Name (Original_Node (First_Index (T)))
2696                  and then Entity (Original_Node (First_Index (T)))
2697                     = Entity (Drange)
2698                then
2699                   if Warn_On_Redundant_Constructs then
2700                      Error_Msg_N ("redundant slice denotes whole array?", N);
2701                   end if;
2702
2703                   --  The following might be a useful optimization ????
2704
2705                   --  Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
2706                end if;
2707             end if;
2708          end;
2709       end if;
2710    end Eval_Slice;
2711
2712    -------------------------
2713    -- Eval_String_Literal --
2714    -------------------------
2715
2716    procedure Eval_String_Literal (N : Node_Id) is
2717       Typ : constant Entity_Id := Etype (N);
2718       Bas : constant Entity_Id := Base_Type (Typ);
2719       Xtp : Entity_Id;
2720       Len : Nat;
2721       Lo  : Node_Id;
2722
2723    begin
2724       --  Nothing to do if error type (handles cases like default expressions
2725       --  or generics where we have not yet fully resolved the type)
2726
2727       if Bas = Any_Type or else Bas = Any_String then
2728          return;
2729       end if;
2730
2731       --  String literals are static if the subtype is static (RM 4.9(2)), so
2732       --  reset the static expression flag (it was set unconditionally in
2733       --  Analyze_String_Literal) if the subtype is non-static. We tell if
2734       --  the subtype is static by looking at the lower bound.
2735
2736       if Ekind (Typ) = E_String_Literal_Subtype then
2737          if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
2738             Set_Is_Static_Expression (N, False);
2739             return;
2740          end if;
2741
2742       --  Here if Etype of string literal is normal Etype (not yet possible,
2743       --  but may be possible in future!)
2744
2745       elsif not Is_OK_Static_Expression
2746                     (Type_Low_Bound (Etype (First_Index (Typ))))
2747       then
2748          Set_Is_Static_Expression (N, False);
2749          return;
2750       end if;
2751
2752       --  If original node was a type conversion, then result if non-static
2753
2754       if Nkind (Original_Node (N)) = N_Type_Conversion then
2755          Set_Is_Static_Expression (N, False);
2756          return;
2757       end if;
2758
2759       --  Test for illegal Ada 95 cases. A string literal is illegal in
2760       --  Ada 95 if its bounds are outside the index base type and this
2761       --  index type is static. This can happen in only two ways. Either
2762       --  the string literal is too long, or it is null, and the lower
2763       --  bound is type'First. In either case it is the upper bound that
2764       --  is out of range of the index type.
2765
2766       if Ada_Version >= Ada_95 then
2767          if Root_Type (Bas) = Standard_String
2768               or else
2769             Root_Type (Bas) = Standard_Wide_String
2770          then
2771             Xtp := Standard_Positive;
2772          else
2773             Xtp := Etype (First_Index (Bas));
2774          end if;
2775
2776          if Ekind (Typ) = E_String_Literal_Subtype then
2777             Lo := String_Literal_Low_Bound (Typ);
2778          else
2779             Lo := Type_Low_Bound (Etype (First_Index (Typ)));
2780          end if;
2781
2782          Len := String_Length (Strval (N));
2783
2784          if UI_From_Int (Len) > String_Type_Len (Bas) then
2785             Apply_Compile_Time_Constraint_Error
2786               (N, "string literal too long for}", CE_Length_Check_Failed,
2787                Ent => Bas,
2788                Typ => First_Subtype (Bas));
2789
2790          elsif Len = 0
2791            and then not Is_Generic_Type (Xtp)
2792            and then
2793              Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
2794          then
2795             Apply_Compile_Time_Constraint_Error
2796               (N, "null string literal not allowed for}",
2797                CE_Length_Check_Failed,
2798                Ent => Bas,
2799                Typ => First_Subtype (Bas));
2800          end if;
2801       end if;
2802    end Eval_String_Literal;
2803
2804    --------------------------
2805    -- Eval_Type_Conversion --
2806    --------------------------
2807
2808    --  A type conversion is potentially static if its subtype mark is for a
2809    --  static scalar subtype, and its operand expression is potentially static
2810    --  (RM 4.9 (10))
2811
2812    procedure Eval_Type_Conversion (N : Node_Id) is
2813       Operand     : constant Node_Id   := Expression (N);
2814       Source_Type : constant Entity_Id := Etype (Operand);
2815       Target_Type : constant Entity_Id := Etype (N);
2816
2817       Stat   : Boolean;
2818       Fold   : Boolean;
2819
2820       function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
2821       --  Returns true if type T is an integer type, or if it is a
2822       --  fixed-point type to be treated as an integer (i.e. the flag
2823       --  Conversion_OK is set on the conversion node).
2824
2825       function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
2826       --  Returns true if type T is a floating-point type, or if it is a
2827       --  fixed-point type that is not to be treated as an integer (i.e. the
2828       --  flag Conversion_OK is not set on the conversion node).
2829
2830       ------------------------------
2831       -- To_Be_Treated_As_Integer --
2832       ------------------------------
2833
2834       function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
2835       begin
2836          return
2837            Is_Integer_Type (T)
2838              or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
2839       end To_Be_Treated_As_Integer;
2840
2841       ---------------------------
2842       -- To_Be_Treated_As_Real --
2843       ---------------------------
2844
2845       function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
2846       begin
2847          return
2848            Is_Floating_Point_Type (T)
2849              or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
2850       end To_Be_Treated_As_Real;
2851
2852    --  Start of processing for Eval_Type_Conversion
2853
2854    begin
2855       --  Cannot fold if target type is non-static or if semantic error
2856
2857       if not Is_Static_Subtype (Target_Type) then
2858          Check_Non_Static_Context (Operand);
2859          return;
2860
2861       elsif Error_Posted (N) then
2862          return;
2863       end if;
2864
2865       --  If not foldable we are done
2866
2867       Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
2868
2869       if not Fold then
2870          return;
2871
2872       --  Don't try fold if target type has constraint error bounds
2873
2874       elsif not Is_OK_Static_Subtype (Target_Type) then
2875          Set_Raises_Constraint_Error (N);
2876          return;
2877       end if;
2878
2879       --  Remaining processing depends on operand types. Note that in the
2880       --  following type test, fixed-point counts as real unless the flag
2881       --  Conversion_OK is set, in which case it counts as integer.
2882
2883       --  Fold conversion, case of string type. The result is not static
2884
2885       if Is_String_Type (Target_Type) then
2886          Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
2887
2888          return;
2889
2890       --  Fold conversion, case of integer target type
2891
2892       elsif To_Be_Treated_As_Integer (Target_Type) then
2893          declare
2894             Result : Uint;
2895
2896          begin
2897             --  Integer to integer conversion
2898
2899             if To_Be_Treated_As_Integer (Source_Type) then
2900                Result := Expr_Value (Operand);
2901
2902             --  Real to integer conversion
2903
2904             else
2905                Result := UR_To_Uint (Expr_Value_R (Operand));
2906             end if;
2907
2908             --  If fixed-point type (Conversion_OK must be set), then the
2909             --  result is logically an integer, but we must replace the
2910             --  conversion with the corresponding real literal, since the
2911             --  type from a semantic point of view is still fixed-point.
2912
2913             if Is_Fixed_Point_Type (Target_Type) then
2914                Fold_Ureal
2915                  (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
2916
2917             --  Otherwise result is integer literal
2918
2919             else
2920                Fold_Uint (N, Result, Stat);
2921             end if;
2922          end;
2923
2924       --  Fold conversion, case of real target type
2925
2926       elsif To_Be_Treated_As_Real (Target_Type) then
2927          declare
2928             Result : Ureal;
2929
2930          begin
2931             if To_Be_Treated_As_Real (Source_Type) then
2932                Result := Expr_Value_R (Operand);
2933             else
2934                Result := UR_From_Uint (Expr_Value (Operand));
2935             end if;
2936
2937             Fold_Ureal (N, Result, Stat);
2938          end;
2939
2940       --  Enumeration types
2941
2942       else
2943          Fold_Uint (N, Expr_Value (Operand), Stat);
2944       end if;
2945
2946       if Is_Out_Of_Range (N, Etype (N)) then
2947          Out_Of_Range (N);
2948       end if;
2949
2950    end Eval_Type_Conversion;
2951
2952    -------------------
2953    -- Eval_Unary_Op --
2954    -------------------
2955
2956    --  Predefined unary operators are static functions (RM 4.9(20)) and thus
2957    --  are potentially static if the operand is potentially static (RM 4.9(7))
2958
2959    procedure Eval_Unary_Op (N : Node_Id) is
2960       Right : constant Node_Id := Right_Opnd (N);
2961       Stat  : Boolean;
2962       Fold  : Boolean;
2963
2964    begin
2965       --  If not foldable we are done
2966
2967       Test_Expression_Is_Foldable (N, Right, Stat, Fold);
2968
2969       if not Fold then
2970          return;
2971       end if;
2972
2973       --  Fold for integer case
2974
2975       if Is_Integer_Type (Etype (N)) then
2976          declare
2977             Rint   : constant Uint := Expr_Value (Right);
2978             Result : Uint;
2979
2980          begin
2981             --  In the case of modular unary plus and abs there is no need
2982             --  to adjust the result of the operation since if the original
2983             --  operand was in bounds the result will be in the bounds of the
2984             --  modular type. However, in the case of modular unary minus the
2985             --  result may go out of the bounds of the modular type and needs
2986             --  adjustment.
2987
2988             if Nkind (N) = N_Op_Plus then
2989                Result := Rint;
2990
2991             elsif Nkind (N) = N_Op_Minus then
2992                if Is_Modular_Integer_Type (Etype (N)) then
2993                   Result := (-Rint) mod Modulus (Etype (N));
2994                else
2995                   Result := (-Rint);
2996                end if;
2997
2998             else
2999                pragma Assert (Nkind (N) = N_Op_Abs);
3000                Result := abs Rint;
3001             end if;
3002
3003             Fold_Uint (N, Result, Stat);
3004          end;
3005
3006       --  Fold for real case
3007
3008       elsif Is_Real_Type (Etype (N)) then
3009          declare
3010             Rreal  : constant Ureal := Expr_Value_R (Right);
3011             Result : Ureal;
3012
3013          begin
3014             if Nkind (N) = N_Op_Plus then
3015                Result := Rreal;
3016
3017             elsif Nkind (N) = N_Op_Minus then
3018                Result := UR_Negate (Rreal);
3019
3020             else
3021                pragma Assert (Nkind (N) = N_Op_Abs);
3022                Result := abs Rreal;
3023             end if;
3024
3025             Fold_Ureal (N, Result, Stat);
3026          end;
3027       end if;
3028    end Eval_Unary_Op;
3029
3030    -------------------------------
3031    -- Eval_Unchecked_Conversion --
3032    -------------------------------
3033
3034    --  Unchecked conversions can never be static, so the only required
3035    --  processing is to check for a non-static context for the operand.
3036
3037    procedure Eval_Unchecked_Conversion (N : Node_Id) is
3038    begin
3039       Check_Non_Static_Context (Expression (N));
3040    end Eval_Unchecked_Conversion;
3041
3042    --------------------
3043    -- Expr_Rep_Value --
3044    --------------------
3045
3046    function Expr_Rep_Value (N : Node_Id) return Uint is
3047       Kind : constant Node_Kind := Nkind (N);
3048       Ent  : Entity_Id;
3049
3050    begin
3051       if Is_Entity_Name (N) then
3052          Ent := Entity (N);
3053
3054          --  An enumeration literal that was either in the source or
3055          --  created as a result of static evaluation.
3056
3057          if Ekind (Ent) = E_Enumeration_Literal then
3058             return Enumeration_Rep (Ent);
3059
3060          --  A user defined static constant
3061
3062          else
3063             pragma Assert (Ekind (Ent) = E_Constant);
3064             return Expr_Rep_Value (Constant_Value (Ent));
3065          end if;
3066
3067       --  An integer literal that was either in the source or created
3068       --  as a result of static evaluation.
3069
3070       elsif Kind = N_Integer_Literal then
3071          return Intval (N);
3072
3073       --  A real literal for a fixed-point type. This must be the fixed-point
3074       --  case, either the literal is of a fixed-point type, or it is a bound
3075       --  of a fixed-point type, with type universal real. In either case we
3076       --  obtain the desired value from Corresponding_Integer_Value.
3077
3078       elsif Kind = N_Real_Literal then
3079          pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3080          return Corresponding_Integer_Value (N);
3081
3082       --  Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3083
3084       elsif Kind = N_Attribute_Reference
3085         and then Attribute_Name (N) = Name_Null_Parameter
3086       then
3087          return Uint_0;
3088
3089       --  Otherwise must be character literal
3090
3091       else
3092          pragma Assert (Kind = N_Character_Literal);
3093          Ent := Entity (N);
3094
3095          --  Since Character literals of type Standard.Character don't
3096          --  have any defining character literals built for them, they
3097          --  do not have their Entity set, so just use their Char
3098          --  code. Otherwise for user-defined character literals use
3099          --  their Pos value as usual which is the same as the Rep value.
3100
3101          if No (Ent) then
3102             return Char_Literal_Value (N);
3103          else
3104             return Enumeration_Rep (Ent);
3105          end if;
3106       end if;
3107    end Expr_Rep_Value;
3108
3109    ----------------
3110    -- Expr_Value --
3111    ----------------
3112
3113    function Expr_Value (N : Node_Id) return Uint is
3114       Kind   : constant Node_Kind := Nkind (N);
3115       CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
3116       Ent    : Entity_Id;
3117       Val    : Uint;
3118
3119    begin
3120       --  If already in cache, then we know it's compile time known and we can
3121       --  return the value that was previously stored in the cache since
3122       --  compile time known values cannot change.
3123
3124       if CV_Ent.N = N then
3125          return CV_Ent.V;
3126       end if;
3127
3128       --  Otherwise proceed to test value
3129
3130       if Is_Entity_Name (N) then
3131          Ent := Entity (N);
3132
3133          --  An enumeration literal that was either in the source or
3134          --  created as a result of static evaluation.
3135
3136          if Ekind (Ent) = E_Enumeration_Literal then
3137             Val := Enumeration_Pos (Ent);
3138
3139          --  A user defined static constant
3140
3141          else
3142             pragma Assert (Ekind (Ent) = E_Constant);
3143             Val := Expr_Value (Constant_Value (Ent));
3144          end if;
3145
3146       --  An integer literal that was either in the source or created
3147       --  as a result of static evaluation.
3148
3149       elsif Kind = N_Integer_Literal then
3150          Val := Intval (N);
3151
3152       --  A real literal for a fixed-point type. This must be the fixed-point
3153       --  case, either the literal is of a fixed-point type, or it is a bound
3154       --  of a fixed-point type, with type universal real. In either case we
3155       --  obtain the desired value from Corresponding_Integer_Value.
3156
3157       elsif Kind = N_Real_Literal then
3158
3159          pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3160          Val := Corresponding_Integer_Value (N);
3161
3162       --  Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3163
3164       elsif Kind = N_Attribute_Reference
3165         and then Attribute_Name (N) = Name_Null_Parameter
3166       then
3167          Val := Uint_0;
3168
3169       --  Otherwise must be character literal
3170
3171       else
3172          pragma Assert (Kind = N_Character_Literal);
3173          Ent := Entity (N);
3174
3175          --  Since Character literals of type Standard.Character don't
3176          --  have any defining character literals built for them, they
3177          --  do not have their Entity set, so just use their Char
3178          --  code. Otherwise for user-defined character literals use
3179          --  their Pos value as usual.
3180
3181          if No (Ent) then
3182             Val := Char_Literal_Value (N);
3183          else
3184             Val := Enumeration_Pos (Ent);
3185          end if;
3186       end if;
3187
3188       --  Come here with Val set to value to be returned, set cache
3189
3190       CV_Ent.N := N;
3191       CV_Ent.V := Val;
3192       return Val;
3193    end Expr_Value;
3194
3195    ------------------
3196    -- Expr_Value_E --
3197    ------------------
3198
3199    function Expr_Value_E (N : Node_Id) return Entity_Id is
3200       Ent  : constant Entity_Id := Entity (N);
3201
3202    begin
3203       if Ekind (Ent) = E_Enumeration_Literal then
3204          return Ent;
3205       else
3206          pragma Assert (Ekind (Ent) = E_Constant);
3207          return Expr_Value_E (Constant_Value (Ent));
3208       end if;
3209    end Expr_Value_E;
3210
3211    ------------------
3212    -- Expr_Value_R --
3213    ------------------
3214
3215    function Expr_Value_R (N : Node_Id) return Ureal is
3216       Kind : constant Node_Kind := Nkind (N);
3217       Ent  : Entity_Id;
3218       Expr : Node_Id;
3219
3220    begin
3221       if Kind = N_Real_Literal then
3222          return Realval (N);
3223
3224       elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
3225          Ent := Entity (N);
3226          pragma Assert (Ekind (Ent) = E_Constant);
3227          return Expr_Value_R (Constant_Value (Ent));
3228
3229       elsif Kind = N_Integer_Literal then
3230          return UR_From_Uint (Expr_Value (N));
3231
3232       --  Strange case of VAX literals, which are at this stage transformed
3233       --  into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in
3234       --  Exp_Vfpt for further details.
3235
3236       elsif Vax_Float (Etype (N))
3237         and then Nkind (N) = N_Unchecked_Type_Conversion
3238       then
3239          Expr := Expression (N);
3240
3241          if Nkind (Expr) = N_Function_Call
3242            and then Present (Parameter_Associations (Expr))
3243          then
3244             Expr := First (Parameter_Associations (Expr));
3245
3246             if Nkind (Expr) = N_Real_Literal then
3247                return Realval (Expr);
3248             end if;
3249          end if;
3250
3251       --  Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
3252
3253       elsif Kind = N_Attribute_Reference
3254         and then Attribute_Name (N) = Name_Null_Parameter
3255       then
3256          return Ureal_0;
3257       end if;
3258
3259       --  If we fall through, we have a node that cannot be interpreted
3260       --  as a compile time constant. That is definitely an error.
3261
3262       raise Program_Error;
3263    end Expr_Value_R;
3264
3265    ------------------
3266    -- Expr_Value_S --
3267    ------------------
3268
3269    function Expr_Value_S (N : Node_Id) return Node_Id is
3270    begin
3271       if Nkind (N) = N_String_Literal then
3272          return N;
3273       else
3274          pragma Assert (Ekind (Entity (N)) = E_Constant);
3275          return Expr_Value_S (Constant_Value (Entity (N)));
3276       end if;
3277    end Expr_Value_S;
3278
3279    --------------------------
3280    -- Flag_Non_Static_Expr --
3281    --------------------------
3282
3283    procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
3284    begin
3285       if Error_Posted (Expr) and then not All_Errors_Mode then
3286          return;
3287       else
3288          Error_Msg_F (Msg, Expr);
3289          Why_Not_Static (Expr);
3290       end if;
3291    end Flag_Non_Static_Expr;
3292
3293    --------------
3294    -- Fold_Str --
3295    --------------
3296
3297    procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
3298       Loc : constant Source_Ptr := Sloc (N);
3299       Typ : constant Entity_Id  := Etype (N);
3300
3301    begin
3302       Rewrite (N, Make_String_Literal (Loc, Strval => Val));
3303
3304       --  We now have the literal with the right value, both the actual type
3305       --  and the expected type of this literal are taken from the expression
3306       --  that was evaluated.
3307
3308       Analyze (N);
3309       Set_Is_Static_Expression (N, Static);
3310       Set_Etype (N, Typ);
3311       Resolve (N);
3312    end Fold_Str;
3313
3314    ---------------
3315    -- Fold_Uint --
3316    ---------------
3317
3318    procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
3319       Loc : constant Source_Ptr := Sloc (N);
3320       Typ : Entity_Id  := Etype (N);
3321       Ent : Entity_Id;
3322
3323    begin
3324       --  If we are folding a named number, retain the entity in the
3325       --  literal, for ASIS use.
3326
3327       if Is_Entity_Name (N)
3328         and then Ekind (Entity (N)) = E_Named_Integer
3329       then
3330          Ent := Entity (N);
3331       else
3332          Ent := Empty;
3333       end if;
3334
3335       if Is_Private_Type (Typ) then
3336          Typ := Full_View (Typ);
3337       end if;
3338
3339       --  For a result of type integer, substitute an N_Integer_Literal node
3340       --  for the result of the compile time evaluation of the expression.
3341       --  For ASIS use, set a link to the original named number when not in
3342       --  a generic context.
3343
3344       if Is_Integer_Type (Typ) then
3345          Rewrite (N, Make_Integer_Literal (Loc, Val));
3346
3347          Set_Original_Entity (N, Ent);
3348
3349       --  Otherwise we have an enumeration type, and we substitute either
3350       --  an N_Identifier or N_Character_Literal to represent the enumeration
3351       --  literal corresponding to the given value, which must always be in
3352       --  range, because appropriate tests have already been made for this.
3353
3354       else pragma Assert (Is_Enumeration_Type (Typ));
3355          Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
3356       end if;
3357
3358       --  We now have the literal with the right value, both the actual type
3359       --  and the expected type of this literal are taken from the expression
3360       --  that was evaluated.
3361
3362       Analyze (N);
3363       Set_Is_Static_Expression (N, Static);
3364       Set_Etype (N, Typ);
3365       Resolve (N);
3366    end Fold_Uint;
3367
3368    ----------------
3369    -- Fold_Ureal --
3370    ----------------
3371
3372    procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
3373       Loc : constant Source_Ptr := Sloc (N);
3374       Typ : constant Entity_Id  := Etype (N);
3375       Ent : Entity_Id;
3376
3377    begin
3378       --  If we are folding a named number, retain the entity in the
3379       --  literal, for ASIS use.
3380
3381       if Is_Entity_Name (N)
3382         and then Ekind (Entity (N)) = E_Named_Real
3383       then
3384          Ent := Entity (N);
3385       else
3386          Ent := Empty;
3387       end if;
3388
3389       Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
3390
3391       --  Set link to original named number, for ASIS use
3392
3393       Set_Original_Entity (N, Ent);
3394
3395       --  Both the actual and expected type comes from the original expression
3396
3397       Analyze (N);
3398       Set_Is_Static_Expression (N, Static);
3399       Set_Etype (N, Typ);
3400       Resolve (N);
3401    end Fold_Ureal;
3402
3403    ---------------
3404    -- From_Bits --
3405    ---------------
3406
3407    function From_Bits (B : Bits; T : Entity_Id) return Uint is
3408       V : Uint := Uint_0;
3409
3410    begin
3411       for J in 0 .. B'Last loop
3412          if B (J) then
3413             V := V + 2 ** J;
3414          end if;
3415       end loop;
3416
3417       if Non_Binary_Modulus (T) then
3418          V := V mod Modulus (T);
3419       end if;
3420
3421       return V;
3422    end From_Bits;
3423
3424    --------------------
3425    -- Get_String_Val --
3426    --------------------
3427
3428    function Get_String_Val (N : Node_Id) return Node_Id is
3429    begin
3430       if Nkind (N) = N_String_Literal then
3431          return N;
3432
3433       elsif Nkind (N) = N_Character_Literal then
3434          return N;
3435
3436       else
3437          pragma Assert (Is_Entity_Name (N));
3438          return Get_String_Val (Constant_Value (Entity (N)));
3439       end if;
3440    end Get_String_Val;
3441
3442    ----------------
3443    -- Initialize --
3444    ----------------
3445
3446    procedure Initialize is
3447    begin
3448       CV_Cache := (others => (Node_High_Bound, Uint_0));
3449    end Initialize;
3450
3451    --------------------
3452    -- In_Subrange_Of --
3453    --------------------
3454
3455    function In_Subrange_Of
3456      (T1        : Entity_Id;
3457       T2        : Entity_Id;
3458       Fixed_Int : Boolean := False) return Boolean
3459    is
3460       L1 : Node_Id;
3461       H1 : Node_Id;
3462
3463       L2 : Node_Id;
3464       H2 : Node_Id;
3465
3466    begin
3467       if T1 = T2 or else Is_Subtype_Of (T1, T2) then
3468          return True;
3469
3470       --  Never in range if both types are not scalar. Don't know if this can
3471       --  actually happen, but just in case.
3472
3473       elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T1) then
3474          return False;
3475
3476       else
3477          L1 := Type_Low_Bound  (T1);
3478          H1 := Type_High_Bound (T1);
3479
3480          L2 := Type_Low_Bound  (T2);
3481          H2 := Type_High_Bound (T2);
3482
3483          --  Check bounds to see if comparison possible at compile time
3484
3485          if Compile_Time_Compare (L1, L2) in Compare_GE
3486               and then
3487             Compile_Time_Compare (H1, H2) in Compare_LE
3488          then
3489             return True;
3490          end if;
3491
3492          --  If bounds not comparable at compile time, then the bounds of T2
3493          --  must be compile time known or we cannot answer the query.
3494
3495          if not Compile_Time_Known_Value (L2)
3496            or else not Compile_Time_Known_Value (H2)
3497          then
3498             return False;
3499          end if;
3500
3501          --  If the bounds of T1 are know at compile time then use these
3502          --  ones, otherwise use the bounds of the base type (which are of
3503          --  course always static).
3504
3505          if not Compile_Time_Known_Value (L1) then
3506             L1 := Type_Low_Bound (Base_Type (T1));
3507          end if;
3508
3509          if not Compile_Time_Known_Value (H1) then
3510             H1 := Type_High_Bound (Base_Type (T1));
3511          end if;
3512
3513          --  Fixed point types should be considered as such only if
3514          --  flag Fixed_Int is set to False.
3515
3516          if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
3517            or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
3518            or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
3519          then
3520             return
3521               Expr_Value_R (L2) <= Expr_Value_R (L1)
3522                 and then
3523               Expr_Value_R (H2) >= Expr_Value_R (H1);
3524
3525          else
3526             return
3527               Expr_Value (L2) <= Expr_Value (L1)
3528                 and then
3529               Expr_Value (H2) >= Expr_Value (H1);
3530
3531          end if;
3532       end if;
3533
3534    --  If any exception occurs, it means that we have some bug in the compiler
3535    --  possibly triggered by a previous error, or by some unforeseen peculiar
3536    --  occurrence. However, this is only an optimization attempt, so there is
3537    --  really no point in crashing the compiler. Instead we just decide, too
3538    --  bad, we can't figure out the answer in this case after all.
3539
3540    exception
3541       when others =>
3542
3543          --  Debug flag K disables this behavior (useful for debugging)
3544
3545          if Debug_Flag_K then
3546             raise;
3547          else
3548             return False;
3549          end if;
3550    end In_Subrange_Of;
3551
3552    -----------------
3553    -- Is_In_Range --
3554    -----------------
3555
3556    function Is_In_Range
3557      (N         : Node_Id;
3558       Typ       : Entity_Id;
3559       Fixed_Int : Boolean := False;
3560       Int_Real  : Boolean := False) return Boolean
3561    is
3562       Val  : Uint;
3563       Valr : Ureal;
3564
3565    begin
3566       --  Universal types have no range limits, so always in range
3567
3568       if Typ = Universal_Integer or else Typ = Universal_Real then
3569          return True;
3570
3571       --  Never in range if not scalar type. Don't know if this can
3572       --  actually happen, but our spec allows it, so we must check!
3573
3574       elsif not Is_Scalar_Type (Typ) then
3575          return False;
3576
3577       --  Never in range unless we have a compile time known value
3578
3579       elsif not Compile_Time_Known_Value (N) then
3580          return False;
3581
3582       else
3583          declare
3584             Lo       : constant Node_Id := Type_Low_Bound  (Typ);
3585             Hi       : constant Node_Id := Type_High_Bound (Typ);
3586             LB_Known : constant Boolean := Compile_Time_Known_Value (Lo);
3587             UB_Known : constant Boolean := Compile_Time_Known_Value (Hi);
3588
3589          begin
3590             --  Fixed point types should be considered as such only in
3591             --  flag Fixed_Int is set to False.
3592
3593             if Is_Floating_Point_Type (Typ)
3594               or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
3595               or else Int_Real
3596             then
3597                Valr := Expr_Value_R (N);
3598
3599                if LB_Known and then Valr >= Expr_Value_R (Lo)
3600                  and then UB_Known and then Valr <= Expr_Value_R (Hi)
3601                then
3602                   return True;
3603                else
3604                   return False;
3605                end if;
3606
3607             else
3608                Val := Expr_Value (N);
3609
3610                if         LB_Known and then Val >= Expr_Value (Lo)
3611                  and then UB_Known and then Val <= Expr_Value (Hi)
3612                then
3613                   return True;
3614                else
3615                   return False;
3616                end if;
3617             end if;
3618          end;
3619       end if;
3620    end Is_In_Range;
3621
3622    -------------------
3623    -- Is_Null_Range --
3624    -------------------
3625
3626    function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
3627       Typ : constant Entity_Id := Etype (Lo);
3628
3629    begin
3630       if not Compile_Time_Known_Value (Lo)
3631         or else not Compile_Time_Known_Value (Hi)
3632       then
3633          return False;
3634       end if;
3635
3636       if Is_Discrete_Type (Typ) then
3637          return Expr_Value (Lo) > Expr_Value (Hi);
3638
3639       else
3640          pragma Assert (Is_Real_Type (Typ));
3641          return Expr_Value_R (Lo) > Expr_Value_R (Hi);
3642       end if;
3643    end Is_Null_Range;
3644
3645    -----------------------------
3646    -- Is_OK_Static_Expression --
3647    -----------------------------
3648
3649    function Is_OK_Static_Expression (N : Node_Id) return Boolean is
3650    begin
3651       return Is_Static_Expression (N)
3652         and then not Raises_Constraint_Error (N);
3653    end Is_OK_Static_Expression;
3654
3655    ------------------------
3656    -- Is_OK_Static_Range --
3657    ------------------------
3658
3659    --  A static range is a range whose bounds are static expressions, or a
3660    --  Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3661    --  We have already converted range attribute references, so we get the
3662    --  "or" part of this rule without needing a special test.
3663
3664    function Is_OK_Static_Range (N : Node_Id) return Boolean is
3665    begin
3666       return Is_OK_Static_Expression (Low_Bound (N))
3667         and then Is_OK_Static_Expression (High_Bound (N));
3668    end Is_OK_Static_Range;
3669
3670    --------------------------
3671    -- Is_OK_Static_Subtype --
3672    --------------------------
3673
3674    --  Determines if Typ is a static subtype as defined in (RM 4.9(26))
3675    --  where neither bound raises constraint error when evaluated.
3676
3677    function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
3678       Base_T   : constant Entity_Id := Base_Type (Typ);
3679       Anc_Subt : Entity_Id;
3680
3681    begin
3682       --  First a quick check on the non static subtype flag. As described
3683       --  in further detail in Einfo, this flag is not decisive in all cases,
3684       --  but if it is set, then the subtype is definitely non-static.
3685
3686       if Is_Non_Static_Subtype (Typ) then
3687          return False;
3688       end if;
3689
3690       Anc_Subt := Ancestor_Subtype (Typ);
3691
3692       if Anc_Subt = Empty then
3693          Anc_Subt := Base_T;
3694       end if;
3695
3696       if Is_Generic_Type (Root_Type (Base_T))
3697         or else Is_Generic_Actual_Type (Base_T)
3698       then
3699          return False;
3700
3701       --  String types
3702
3703       elsif Is_String_Type (Typ) then
3704          return
3705            Ekind (Typ) = E_String_Literal_Subtype
3706              or else
3707            (Is_OK_Static_Subtype (Component_Type (Typ))
3708               and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
3709
3710       --  Scalar types
3711
3712       elsif Is_Scalar_Type (Typ) then
3713          if Base_T = Typ then
3714             return True;
3715
3716          else
3717             --  Scalar_Range (Typ) might be an N_Subtype_Indication, so
3718             --  use Get_Type_Low,High_Bound.
3719
3720             return     Is_OK_Static_Subtype (Anc_Subt)
3721               and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
3722               and then Is_OK_Static_Expression (Type_High_Bound (Typ));
3723          end if;
3724
3725       --  Types other than string and scalar types are never static
3726
3727       else
3728          return False;
3729       end if;
3730    end Is_OK_Static_Subtype;
3731
3732    ---------------------
3733    -- Is_Out_Of_Range --
3734    ---------------------
3735
3736    function Is_Out_Of_Range
3737      (N         : Node_Id;
3738       Typ       : Entity_Id;
3739       Fixed_Int : Boolean := False;
3740       Int_Real  : Boolean := False) return Boolean
3741    is
3742       Val  : Uint;
3743       Valr : Ureal;
3744
3745    begin
3746       --  Universal types have no range limits, so always in range
3747
3748       if Typ = Universal_Integer or else Typ = Universal_Real then
3749          return False;
3750
3751       --  Never out of range if not scalar type. Don't know if this can
3752       --  actually happen, but our spec allows it, so we must check!
3753
3754       elsif not Is_Scalar_Type (Typ) then
3755          return False;
3756
3757       --  Never out of range if this is a generic type, since the bounds
3758       --  of generic types are junk. Note that if we only checked for
3759       --  static expressions (instead of compile time known values) below,
3760       --  we would not need this check, because values of a generic type
3761       --  can never be static, but they can be known at compile time.
3762
3763       elsif Is_Generic_Type (Typ) then
3764          return False;
3765
3766       --  Never out of range unless we have a compile time known value
3767
3768       elsif not Compile_Time_Known_Value (N) then
3769          return False;
3770
3771       else
3772          declare
3773             Lo       : constant Node_Id := Type_Low_Bound  (Typ);
3774             Hi       : constant Node_Id := Type_High_Bound (Typ);
3775             LB_Known : constant Boolean := Compile_Time_Known_Value (Lo);
3776             UB_Known : constant Boolean := Compile_Time_Known_Value (Hi);
3777
3778          begin
3779             --  Real types (note that fixed-point types are not treated
3780             --  as being of a real type if the flag Fixed_Int is set,
3781             --  since in that case they are regarded as integer types).
3782
3783             if Is_Floating_Point_Type (Typ)
3784               or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
3785               or else Int_Real
3786             then
3787                Valr := Expr_Value_R (N);
3788
3789                if LB_Known and then Valr < Expr_Value_R (Lo) then
3790                   return True;
3791
3792                elsif UB_Known and then Expr_Value_R (Hi) < Valr then
3793                   return True;
3794
3795                else
3796                   return False;
3797                end if;
3798
3799             else
3800                Val := Expr_Value (N);
3801
3802                if LB_Known and then Val < Expr_Value (Lo) then
3803                   return True;
3804
3805                elsif UB_Known and then Expr_Value (Hi) < Val then
3806                   return True;
3807
3808                else
3809                   return False;
3810                end if;
3811             end if;
3812          end;
3813       end if;
3814    end Is_Out_Of_Range;
3815
3816    ---------------------
3817    -- Is_Static_Range --
3818    ---------------------
3819
3820    --  A static range is a range whose bounds are static expressions, or a
3821    --  Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3822    --  We have already converted range attribute references, so we get the
3823    --  "or" part of this rule without needing a special test.
3824
3825    function Is_Static_Range (N : Node_Id) return Boolean is
3826    begin
3827       return Is_Static_Expression (Low_Bound (N))
3828         and then Is_Static_Expression (High_Bound (N));
3829    end Is_Static_Range;
3830
3831    -----------------------
3832    -- Is_Static_Subtype --
3833    -----------------------
3834
3835    --  Determines if Typ is a static subtype as defined in (RM 4.9(26))
3836
3837    function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
3838       Base_T   : constant Entity_Id := Base_Type (Typ);
3839       Anc_Subt : Entity_Id;
3840
3841    begin
3842       --  First a quick check on the non static subtype flag. As described
3843       --  in further detail in Einfo, this flag is not decisive in all cases,
3844       --  but if it is set, then the subtype is definitely non-static.
3845
3846       if Is_Non_Static_Subtype (Typ) then
3847          return False;
3848       end if;
3849
3850       Anc_Subt := Ancestor_Subtype (Typ);
3851
3852       if Anc_Subt = Empty then
3853          Anc_Subt := Base_T;
3854       end if;
3855
3856       if Is_Generic_Type (Root_Type (Base_T))
3857         or else Is_Generic_Actual_Type (Base_T)
3858       then
3859          return False;
3860
3861       --  String types
3862
3863       elsif Is_String_Type (Typ) then
3864          return
3865            Ekind (Typ) = E_String_Literal_Subtype
3866              or else
3867            (Is_Static_Subtype (Component_Type (Typ))
3868               and then Is_Static_Subtype (Etype (First_Index (Typ))));
3869
3870       --  Scalar types
3871
3872       elsif Is_Scalar_Type (Typ) then
3873          if Base_T = Typ then
3874             return True;
3875
3876          else
3877             return     Is_Static_Subtype (Anc_Subt)
3878               and then Is_Static_Expression (Type_Low_Bound (Typ))
3879               and then Is_Static_Expression (Type_High_Bound (Typ));
3880          end if;
3881
3882       --  Types other than string and scalar types are never static
3883
3884       else
3885          return False;
3886       end if;
3887    end Is_Static_Subtype;
3888
3889    --------------------
3890    -- Not_Null_Range --
3891    --------------------
3892
3893    function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
3894       Typ : constant Entity_Id := Etype (Lo);
3895
3896    begin
3897       if not Compile_Time_Known_Value (Lo)
3898         or else not Compile_Time_Known_Value (Hi)
3899       then
3900          return False;
3901       end if;
3902
3903       if Is_Discrete_Type (Typ) then
3904          return Expr_Value (Lo) <= Expr_Value (Hi);
3905
3906       else
3907          pragma Assert (Is_Real_Type (Typ));
3908
3909          return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
3910       end if;
3911    end Not_Null_Range;
3912
3913    -------------
3914    -- OK_Bits --
3915    -------------
3916
3917    function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
3918    begin
3919       --  We allow a maximum of 500,000 bits which seems a reasonable limit
3920
3921       if Bits < 500_000 then
3922          return True;
3923
3924       else
3925          Error_Msg_N ("static value too large, capacity exceeded", N);
3926          return False;
3927       end if;
3928    end OK_Bits;
3929
3930    ------------------
3931    -- Out_Of_Range --
3932    ------------------
3933
3934    procedure Out_Of_Range (N : Node_Id) is
3935    begin
3936       --  If we have the static expression case, then this is an illegality
3937       --  in Ada 95 mode, except that in an instance, we never generate an
3938       --  error (if the error is legitimate, it was already diagnosed in
3939       --  the template). The expression to compute the length of a packed
3940       --  array is attached to the array type itself, and deserves a separate
3941       --  message.
3942
3943       if Is_Static_Expression (N)
3944         and then not In_Instance
3945         and then not In_Inlined_Body
3946         and then Ada_Version >= Ada_95
3947       then
3948          if Nkind (Parent (N)) = N_Defining_Identifier
3949            and then Is_Array_Type (Parent (N))
3950            and then Present (Packed_Array_Type (Parent (N)))
3951            and then Present (First_Rep_Item (Parent (N)))
3952          then
3953             Error_Msg_N
3954              ("length of packed array must not exceed Integer''Last",
3955               First_Rep_Item (Parent (N)));
3956             Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
3957
3958          else
3959             Apply_Compile_Time_Constraint_Error
3960               (N, "value not in range of}", CE_Range_Check_Failed);
3961          end if;
3962
3963       --  Here we generate a warning for the Ada 83 case, or when we are
3964       --  in an instance, or when we have a non-static expression case.
3965
3966       else
3967          Apply_Compile_Time_Constraint_Error
3968            (N, "value not in range of}?", CE_Range_Check_Failed);
3969       end if;
3970    end Out_Of_Range;
3971
3972    -------------------------
3973    -- Rewrite_In_Raise_CE --
3974    -------------------------
3975
3976    procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
3977       Typ : constant Entity_Id := Etype (N);
3978
3979    begin
3980       --  If we want to raise CE in the condition of a raise_CE node
3981       --  we may as well get rid of the condition
3982
3983       if Present (Parent (N))
3984         and then Nkind (Parent (N)) = N_Raise_Constraint_Error
3985       then
3986          Set_Condition (Parent (N), Empty);
3987
3988       --  If the expression raising CE is a N_Raise_CE node, we can use
3989       --  that one. We just preserve the type of the context
3990
3991       elsif Nkind (Exp) = N_Raise_Constraint_Error then
3992          Rewrite (N, Exp);
3993          Set_Etype (N, Typ);
3994
3995       --  We have to build an explicit raise_ce node
3996
3997       else
3998          Rewrite (N,
3999            Make_Raise_Constraint_Error (Sloc (Exp),
4000              Reason => CE_Range_Check_Failed));
4001          Set_Raises_Constraint_Error (N);
4002          Set_Etype (N, Typ);
4003       end if;
4004    end Rewrite_In_Raise_CE;
4005
4006    ---------------------
4007    -- String_Type_Len --
4008    ---------------------
4009
4010    function String_Type_Len (Stype : Entity_Id) return Uint is
4011       NT : constant Entity_Id := Etype (First_Index (Stype));
4012       T  : Entity_Id;
4013
4014    begin
4015       if Is_OK_Static_Subtype (NT) then
4016          T := NT;
4017       else
4018          T := Base_Type (NT);
4019       end if;
4020
4021       return Expr_Value (Type_High_Bound (T)) -
4022              Expr_Value (Type_Low_Bound (T)) + 1;
4023    end String_Type_Len;
4024
4025    ------------------------------------
4026    -- Subtypes_Statically_Compatible --
4027    ------------------------------------
4028
4029    function Subtypes_Statically_Compatible
4030      (T1 : Entity_Id;
4031       T2 : Entity_Id) return Boolean
4032    is
4033    begin
4034       if Is_Scalar_Type (T1) then
4035
4036          --  Definitely compatible if we match
4037
4038          if Subtypes_Statically_Match (T1, T2) then
4039             return True;
4040
4041          --  If either subtype is nonstatic then they're not compatible
4042
4043          elsif not Is_Static_Subtype (T1)
4044            or else not Is_Static_Subtype (T2)
4045          then
4046             return False;
4047
4048          --  If either type has constraint error bounds, then consider that
4049          --  they match to avoid junk cascaded errors here.
4050
4051          elsif not Is_OK_Static_Subtype (T1)
4052            or else not Is_OK_Static_Subtype (T2)
4053          then
4054             return True;
4055
4056          --  Base types must match, but we don't check that (should
4057          --  we???) but we do at least check that both types are
4058          --  real, or both types are not real.
4059
4060          elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
4061             return False;
4062
4063          --  Here we check the bounds
4064
4065          else
4066             declare
4067                LB1 : constant Node_Id := Type_Low_Bound  (T1);
4068                HB1 : constant Node_Id := Type_High_Bound (T1);
4069                LB2 : constant Node_Id := Type_Low_Bound  (T2);
4070                HB2 : constant Node_Id := Type_High_Bound (T2);
4071
4072             begin
4073                if Is_Real_Type (T1) then
4074                   return
4075                     (Expr_Value_R (LB1) > Expr_Value_R (HB1))
4076                       or else
4077                     (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
4078                        and then
4079                      Expr_Value_R (HB1) <= Expr_Value_R (HB2));
4080
4081                else
4082                   return
4083                     (Expr_Value (LB1) > Expr_Value (HB1))
4084                       or else
4085                     (Expr_Value (LB2) <= Expr_Value (LB1)
4086                        and then
4087                      Expr_Value (HB1) <= Expr_Value (HB2));
4088                end if;
4089             end;
4090          end if;
4091
4092       elsif Is_Access_Type (T1) then
4093          return not Is_Constrained (T2)
4094            or else Subtypes_Statically_Match
4095                      (Designated_Type (T1), Designated_Type (T2));
4096
4097       else
4098          return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
4099            or else Subtypes_Statically_Match (T1, T2);
4100       end if;
4101    end Subtypes_Statically_Compatible;
4102
4103    -------------------------------
4104    -- Subtypes_Statically_Match --
4105    -------------------------------
4106
4107    --  Subtypes statically match if they have statically matching constraints
4108    --  (RM 4.9.1(2)). Constraints statically match if there are none, or if
4109    --  they are the same identical constraint, or if they are static and the
4110    --  values match (RM 4.9.1(1)).
4111
4112    function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is
4113    begin
4114       --  A type always statically matches itself
4115
4116       if T1 = T2 then
4117          return True;
4118
4119       --  Scalar types
4120
4121       elsif Is_Scalar_Type (T1) then
4122
4123          --  Base types must be the same
4124
4125          if Base_Type (T1) /= Base_Type (T2) then
4126             return False;
4127          end if;
4128
4129          --  A constrained numeric subtype never matches an unconstrained
4130          --  subtype, i.e. both types must be constrained or unconstrained.
4131
4132          --  To understand the requirement for this test, see RM 4.9.1(1).
4133          --  As is made clear in RM 3.5.4(11), type Integer, for example
4134          --  is a constrained subtype with constraint bounds matching the
4135          --  bounds of its corresponding unconstrained base type. In this
4136          --  situation, Integer and Integer'Base do not statically match,
4137          --  even though they have the same bounds.
4138
4139          --  We only apply this test to types in Standard and types that
4140          --  appear in user programs. That way, we do not have to be
4141          --  too careful about setting Is_Constrained right for itypes.
4142
4143          if Is_Numeric_Type (T1)
4144            and then (Is_Constrained (T1) /= Is_Constrained (T2))
4145            and then (Scope (T1) = Standard_Standard
4146                       or else Comes_From_Source (T1))
4147            and then (Scope (T2) = Standard_Standard
4148                       or else Comes_From_Source (T2))
4149          then
4150             return False;
4151
4152          --  A generic scalar type does not statically match its base
4153          --  type (AI-311). In this case we make sure that the formals,
4154          --  which are first subtypes of their bases, are constrained.
4155
4156          elsif Is_Generic_Type (T1)
4157            and then Is_Generic_Type (T2)
4158            and then (Is_Constrained (T1) /= Is_Constrained (T2))
4159          then
4160             return False;
4161          end if;
4162
4163          --  If there was an error in either range, then just assume
4164          --  the types statically match to avoid further junk errors
4165
4166          if Error_Posted (Scalar_Range (T1))
4167               or else
4168             Error_Posted (Scalar_Range (T2))
4169          then
4170             return True;
4171          end if;
4172
4173          --  Otherwise both types have bound that can be compared
4174
4175          declare
4176             LB1 : constant Node_Id := Type_Low_Bound  (T1);
4177             HB1 : constant Node_Id := Type_High_Bound (T1);
4178             LB2 : constant Node_Id := Type_Low_Bound  (T2);
4179             HB2 : constant Node_Id := Type_High_Bound (T2);
4180
4181          begin
4182             --  If the bounds are the same tree node, then match
4183
4184             if LB1 = LB2 and then HB1 = HB2 then
4185                return True;
4186
4187             --  Otherwise bounds must be static and identical value
4188
4189             else
4190                if not Is_Static_Subtype (T1)
4191                  or else not Is_Static_Subtype (T2)
4192                then
4193                   return False;
4194
4195                --  If either type has constraint error bounds, then say
4196                --  that they match to avoid junk cascaded errors here.
4197
4198                elsif not Is_OK_Static_Subtype (T1)
4199                  or else not Is_OK_Static_Subtype (T2)
4200                then
4201                   return True;
4202
4203                elsif Is_Real_Type (T1) then
4204                   return
4205                     (Expr_Value_R (LB1) = Expr_Value_R (LB2))
4206                       and then
4207                     (Expr_Value_R (HB1) = Expr_Value_R (HB2));
4208
4209                else
4210                   return
4211                     Expr_Value (LB1) = Expr_Value (LB2)
4212                       and then
4213                     Expr_Value (HB1) = Expr_Value (HB2);
4214                end if;
4215             end if;
4216          end;
4217
4218       --  Type with discriminants
4219
4220       elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
4221
4222          --  Because of view exchanges in multiple instantiations, conformance
4223          --  checking might try to match a partial view of a type with no
4224          --  discriminants with a full view that has defaulted discriminants.
4225          --  In such a case, use the discriminant constraint of the full view,
4226          --  which must exist because we know that the two subtypes have the
4227          --  same base type.
4228
4229          if Has_Discriminants (T1) /= Has_Discriminants (T2) then
4230             if In_Instance then
4231                if Is_Private_Type (T2)
4232                  and then Present (Full_View (T2))
4233                  and then Has_Discriminants (Full_View (T2))
4234                then
4235                   return Subtypes_Statically_Match (T1, Full_View (T2));
4236
4237                elsif Is_Private_Type (T1)
4238                  and then Present (Full_View (T1))
4239                  and then Has_Discriminants (Full_View (T1))
4240                then
4241                   return Subtypes_Statically_Match (Full_View (T1), T2);
4242
4243                else
4244                   return False;
4245                end if;
4246             else
4247                return False;
4248             end if;
4249          end if;
4250
4251          declare
4252             DL1 : constant Elist_Id := Discriminant_Constraint (T1);
4253             DL2 : constant Elist_Id := Discriminant_Constraint (T2);
4254
4255             DA1 : Elmt_Id;
4256             DA2 : Elmt_Id;
4257
4258          begin
4259             if DL1 = DL2 then
4260                return True;
4261             elsif Is_Constrained (T1) /= Is_Constrained (T2) then
4262                return False;
4263             end if;
4264
4265             --  Now loop through the discriminant constraints
4266
4267             --  Note: the guard here seems necessary, since it is possible at
4268             --  least for DL1 to be No_Elist. Not clear this is reasonable ???
4269
4270             if Present (DL1) and then Present (DL2) then
4271                DA1 := First_Elmt (DL1);
4272                DA2 := First_Elmt (DL2);
4273                while Present (DA1) loop
4274                   declare
4275                      Expr1 : constant Node_Id := Node (DA1);
4276                      Expr2 : constant Node_Id := Node (DA2);
4277
4278                   begin
4279                      if not Is_Static_Expression (Expr1)
4280                        or else not Is_Static_Expression (Expr2)
4281                      then
4282                         return False;
4283
4284                         --  If either expression raised a constraint error,
4285                         --  consider the expressions as matching, since this
4286                         --  helps to prevent cascading errors.
4287
4288                      elsif Raises_Constraint_Error (Expr1)
4289                        or else Raises_Constraint_Error (Expr2)
4290                      then
4291                         null;
4292
4293                      elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
4294                         return False;
4295                      end if;
4296                   end;
4297
4298                   Next_Elmt (DA1);
4299                   Next_Elmt (DA2);
4300                end loop;
4301             end if;
4302          end;
4303
4304          return True;
4305
4306       --  A definite type does not match an indefinite or classwide type
4307       --  However, a generic type with unknown discriminants may be
4308       --  instantiated with a type with no discriminants, and conformance
4309       --  checking on an inherited operation may compare the actual with
4310       --  the subtype that renames it in the instance.
4311
4312       elsif
4313          Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
4314       then
4315          return
4316            Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2);
4317
4318       --  Array type
4319
4320       elsif Is_Array_Type (T1) then
4321
4322          --  If either subtype is unconstrained then both must be,
4323          --  and if both are unconstrained then no further checking
4324          --  is needed.
4325
4326          if not Is_Constrained (T1) or else not Is_Constrained (T2) then
4327             return not (Is_Constrained (T1) or else Is_Constrained (T2));
4328          end if;
4329
4330          --  Both subtypes are constrained, so check that the index
4331          --  subtypes statically match.
4332
4333          declare
4334             Index1 : Node_Id := First_Index (T1);
4335             Index2 : Node_Id := First_Index (T2);
4336
4337          begin
4338             while Present (Index1) loop
4339                if not
4340                  Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
4341                then
4342                   return False;
4343                end if;
4344
4345                Next_Index (Index1);
4346                Next_Index (Index2);
4347             end loop;
4348
4349             return True;
4350          end;
4351
4352       elsif Is_Access_Type (T1) then
4353          if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
4354             return False;
4355
4356          elsif Ekind (T1) = E_Access_Subprogram_Type
4357            or else Ekind (T1) = E_Anonymous_Access_Subprogram_Type
4358          then
4359             return
4360               Subtype_Conformant
4361                 (Designated_Type (T1),
4362                  Designated_Type (T2));
4363          else
4364             return
4365               Subtypes_Statically_Match
4366                 (Designated_Type (T1),
4367                  Designated_Type (T2))
4368               and then Is_Access_Constant (T1) = Is_Access_Constant (T2);
4369          end if;
4370
4371       --  All other types definitely match
4372
4373       else
4374          return True;
4375       end if;
4376    end Subtypes_Statically_Match;
4377
4378    ----------
4379    -- Test --
4380    ----------
4381
4382    function Test (Cond : Boolean) return Uint is
4383    begin
4384       if Cond then
4385          return Uint_1;
4386       else
4387          return Uint_0;
4388       end if;
4389    end Test;
4390
4391    ---------------------------------
4392    -- Test_Expression_Is_Foldable --
4393    ---------------------------------
4394
4395    --  One operand case
4396
4397    procedure Test_Expression_Is_Foldable
4398      (N    : Node_Id;
4399       Op1  : Node_Id;
4400       Stat : out Boolean;
4401       Fold : out Boolean)
4402    is
4403    begin
4404       Stat := False;
4405       Fold := False;
4406
4407       if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
4408          return;
4409       end if;
4410
4411       --  If operand is Any_Type, just propagate to result and do not
4412       --  try to fold, this prevents cascaded errors.
4413
4414       if Etype (Op1) = Any_Type then
4415          Set_Etype (N, Any_Type);
4416          return;
4417
4418       --  If operand raises constraint error, then replace node N with the
4419       --  raise constraint error node, and we are obviously not foldable.
4420       --  Note that this replacement inherits the Is_Static_Expression flag
4421       --  from the operand.
4422
4423       elsif Raises_Constraint_Error (Op1) then
4424          Rewrite_In_Raise_CE (N, Op1);
4425          return;
4426
4427       --  If the operand is not static, then the result is not static, and
4428       --  all we have to do is to check the operand since it is now known
4429       --  to appear in a non-static context.
4430
4431       elsif not Is_Static_Expression (Op1) then
4432          Check_Non_Static_Context (Op1);
4433          Fold := Compile_Time_Known_Value (Op1);
4434          return;
4435
4436       --   An expression of a formal modular type is not foldable because
4437       --   the modulus is unknown.
4438
4439       elsif Is_Modular_Integer_Type (Etype (Op1))
4440         and then Is_Generic_Type (Etype (Op1))
4441       then
4442          Check_Non_Static_Context (Op1);
4443          return;
4444
4445       --  Here we have the case of an operand whose type is OK, which is
4446       --  static, and which does not raise constraint error, we can fold.
4447
4448       else
4449          Set_Is_Static_Expression (N);
4450          Fold := True;
4451          Stat := True;
4452       end if;
4453    end Test_Expression_Is_Foldable;
4454
4455    --  Two operand case
4456
4457    procedure Test_Expression_Is_Foldable
4458      (N    : Node_Id;
4459       Op1  : Node_Id;
4460       Op2  : Node_Id;
4461       Stat : out Boolean;
4462       Fold : out Boolean)
4463    is
4464       Rstat : constant Boolean := Is_Static_Expression (Op1)
4465                                     and then Is_Static_Expression (Op2);
4466
4467    begin
4468       Stat := False;
4469       Fold := False;
4470
4471       if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
4472          return;
4473       end if;
4474
4475       --  If either operand is Any_Type, just propagate to result and
4476       --  do not try to fold, this prevents cascaded errors.
4477
4478       if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
4479          Set_Etype (N, Any_Type);
4480          return;
4481
4482       --  If left operand raises constraint error, then replace node N with
4483       --  the raise constraint error node, and we are obviously not foldable.
4484       --  Is_Static_Expression is set from the two operands in the normal way,
4485       --  and we check the right operand if it is in a non-static context.
4486
4487       elsif Raises_Constraint_Error (Op1) then
4488          if not Rstat then
4489             Check_Non_Static_Context (Op2);
4490          end if;
4491
4492          Rewrite_In_Raise_CE (N, Op1);
4493          Set_Is_Static_Expression (N, Rstat);
4494          return;
4495
4496       --  Similar processing for the case of the right operand. Note that
4497       --  we don't use this routine for the short-circuit case, so we do
4498       --  not have to worry about that special case here.
4499
4500       elsif Raises_Constraint_Error (Op2) then
4501          if not Rstat then
4502             Check_Non_Static_Context (Op1);
4503          end if;
4504
4505          Rewrite_In_Raise_CE (N, Op2);
4506          Set_Is_Static_Expression (N, Rstat);
4507          return;
4508
4509       --  Exclude expressions of a generic modular type, as above
4510
4511       elsif Is_Modular_Integer_Type (Etype (Op1))
4512         and then Is_Generic_Type (Etype (Op1))
4513       then
4514          Check_Non_Static_Context (Op1);
4515          return;
4516
4517       --  If result is not static, then check non-static contexts on operands
4518       --  since one of them may be static and the other one may not be static
4519
4520       elsif not Rstat then
4521          Check_Non_Static_Context (Op1);
4522          Check_Non_Static_Context (Op2);
4523          Fold := Compile_Time_Known_Value (Op1)
4524                    and then Compile_Time_Known_Value (Op2);
4525          return;
4526
4527       --  Else result is static and foldable. Both operands are static,
4528       --  and neither raises constraint error, so we can definitely fold.
4529
4530       else
4531          Set_Is_Static_Expression (N);
4532          Fold := True;
4533          Stat := True;
4534          return;
4535       end if;
4536    end Test_Expression_Is_Foldable;
4537
4538    --------------
4539    -- To_Bits --
4540    --------------
4541
4542    procedure To_Bits (U : Uint; B : out Bits) is
4543    begin
4544       for J in 0 .. B'Last loop
4545          B (J) := (U / (2 ** J)) mod 2 /= 0;
4546       end loop;
4547    end To_Bits;
4548
4549    --------------------
4550    -- Why_Not_Static --
4551    --------------------
4552
4553    procedure Why_Not_Static (Expr : Node_Id) is
4554       N   : constant Node_Id   := Original_Node (Expr);
4555       Typ : Entity_Id;
4556       E   : Entity_Id;
4557
4558       procedure Why_Not_Static_List (L : List_Id);
4559       --  A version that can be called on a list of expressions. Finds
4560       --  all non-static violations in any element of the list.
4561
4562       -------------------------
4563       -- Why_Not_Static_List --
4564       -------------------------
4565
4566       procedure Why_Not_Static_List (L : List_Id) is
4567          N : Node_Id;
4568
4569       begin
4570          if Is_Non_Empty_List (L) then
4571             N := First (L);
4572             while Present (N) loop
4573                Why_Not_Static (N);
4574                Next (N);
4575             end loop;
4576          end if;
4577       end Why_Not_Static_List;
4578
4579    --  Start of processing for Why_Not_Static
4580
4581    begin
4582       --  If in ACATS mode (debug flag 2), then suppress all these
4583       --  messages, this avoids massive updates to the ACATS base line.
4584
4585       if Debug_Flag_2 then
4586          return;
4587       end if;
4588
4589       --  Ignore call on error or empty node
4590
4591       if No (Expr) or else Nkind (Expr) = N_Error then
4592          return;
4593       end if;
4594
4595       --  Preprocessing for sub expressions
4596
4597       if Nkind (Expr) in N_Subexpr then
4598
4599          --  Nothing to do if expression is static
4600
4601          if Is_OK_Static_Expression (Expr) then
4602             return;
4603          end if;
4604
4605          --  Test for constraint error raised
4606
4607          if Raises_Constraint_Error (Expr) then
4608             Error_Msg_N
4609               ("expression raises exception, cannot be static " &
4610                "(RM 4.9(34))!", N);
4611             return;
4612          end if;
4613
4614          --  If no type, then something is pretty wrong, so ignore
4615
4616          Typ := Etype (Expr);
4617
4618          if No (Typ) then
4619             return;
4620          end if;
4621
4622          --  Type must be scalar or string type
4623
4624          if not Is_Scalar_Type (Typ)
4625            and then not Is_String_Type (Typ)
4626          then
4627             Error_Msg_N
4628               ("static expression must have scalar or string type " &
4629                "(RM 4.9(2))!", N);
4630             return;
4631          end if;
4632       end if;
4633
4634       --  If we got through those checks, test particular node kind
4635
4636       case Nkind (N) is
4637          when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
4638             E := Entity (N);
4639
4640             if Is_Named_Number (E) then
4641                null;
4642
4643             elsif Ekind (E) = E_Constant then
4644                if not Is_Static_Expression (Constant_Value (E)) then
4645                   Error_Msg_NE
4646                     ("& is not a static constant (RM 4.9(5))!", N, E);
4647                end if;
4648
4649             else
4650                Error_Msg_NE
4651                  ("& is not static constant or named number " &
4652                   "(RM 4.9(5))!", N, E);
4653             end if;
4654
4655          when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test =>
4656             if Nkind (N) in N_Op_Shift then
4657                Error_Msg_N
4658                 ("shift functions are never static (RM 4.9(6,18))!", N);
4659
4660             else
4661                Why_Not_Static (Left_Opnd (N));
4662                Why_Not_Static (Right_Opnd (N));
4663             end if;
4664
4665          when N_Unary_Op =>
4666             Why_Not_Static (Right_Opnd (N));
4667
4668          when N_Attribute_Reference =>
4669             Why_Not_Static_List (Expressions (N));
4670
4671             E := Etype (Prefix (N));
4672
4673             if E = Standard_Void_Type then
4674                return;
4675             end if;
4676
4677             --  Special case non-scalar'Size since this is a common error
4678
4679             if Attribute_Name (N) = Name_Size then
4680                Error_Msg_N
4681                  ("size attribute is only static for scalar type " &
4682                   "(RM 4.9(7,8))", N);
4683
4684             --  Flag array cases
4685
4686             elsif Is_Array_Type (E) then
4687                if Attribute_Name (N) /= Name_First
4688                     and then
4689                   Attribute_Name (N) /= Name_Last
4690                     and then
4691                   Attribute_Name (N) /= Name_Length
4692                then
4693                   Error_Msg_N
4694                     ("static array attribute must be Length, First, or Last " &
4695                      "(RM 4.9(8))!", N);
4696
4697                --  Since we know the expression is not-static (we already
4698                --  tested for this, must mean array is not static).
4699
4700                else
4701                   Error_Msg_N
4702                     ("prefix is non-static array (RM 4.9(8))!", Prefix (N));
4703                end if;
4704
4705                return;
4706
4707             --  Special case generic types, since again this is a common
4708             --  source of confusion.
4709
4710             elsif Is_Generic_Actual_Type (E)
4711                     or else
4712                   Is_Generic_Type (E)
4713             then
4714                Error_Msg_N
4715                  ("attribute of generic type is never static " &
4716                   "(RM 4.9(7,8))!", N);
4717
4718             elsif Is_Static_Subtype (E) then
4719                null;
4720
4721             elsif Is_Scalar_Type (E) then
4722                Error_Msg_N
4723                  ("prefix type for attribute is not static scalar subtype " &
4724                   "(RM 4.9(7))!", N);
4725
4726             else
4727                Error_Msg_N
4728                  ("static attribute must apply to array/scalar type " &
4729                   "(RM 4.9(7,8))!", N);
4730             end if;
4731
4732          when N_String_Literal =>
4733             Error_Msg_N
4734               ("subtype of string literal is non-static (RM 4.9(4))!", N);
4735
4736          when N_Explicit_Dereference =>
4737             Error_Msg_N
4738               ("explicit dereference is never static (RM 4.9)!", N);
4739
4740          when N_Function_Call =>
4741             Why_Not_Static_List (Parameter_Associations (N));
4742             Error_Msg_N ("non-static function call (RM 4.9(6,18))!", N);
4743
4744          when N_Parameter_Association =>
4745             Why_Not_Static (Explicit_Actual_Parameter (N));
4746
4747          when N_Indexed_Component =>
4748             Error_Msg_N
4749               ("indexed component is never static (RM 4.9)!", N);
4750
4751          when N_Procedure_Call_Statement =>
4752             Error_Msg_N
4753               ("procedure call is never static (RM 4.9)!", N);
4754
4755          when N_Qualified_Expression =>
4756             Why_Not_Static (Expression (N));
4757
4758          when N_Aggregate | N_Extension_Aggregate =>
4759             Error_Msg_N
4760               ("an aggregate is never static (RM 4.9)!", N);
4761
4762          when N_Range =>
4763             Why_Not_Static (Low_Bound (N));
4764             Why_Not_Static (High_Bound (N));
4765
4766          when N_Range_Constraint =>
4767             Why_Not_Static (Range_Expression (N));
4768
4769          when N_Subtype_Indication =>
4770             Why_Not_Static (Constraint (N));
4771
4772          when N_Selected_Component =>
4773             Error_Msg_N
4774               ("selected component is never static (RM 4.9)!", N);
4775
4776          when N_Slice =>
4777             Error_Msg_N
4778               ("slice is never static (RM 4.9)!", N);
4779
4780          when N_Type_Conversion =>
4781             Why_Not_Static (Expression (N));
4782
4783             if not Is_Scalar_Type (Etype (Prefix (N)))
4784               or else not Is_Static_Subtype (Etype (Prefix (N)))
4785             then
4786                Error_Msg_N
4787                  ("static conversion requires static scalar subtype result " &
4788                   "(RM 4.9(9))!", N);
4789             end if;
4790
4791          when N_Unchecked_Type_Conversion =>
4792             Error_Msg_N
4793               ("unchecked type conversion is never static (RM 4.9)!", N);
4794
4795          when others =>
4796             null;
4797
4798       end case;
4799    end Why_Not_Static;
4800
4801 end Sem_Eval;