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