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