gcc/ada/sem_attr.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ A T T R                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
  27
  28 with Atree;    use Atree;
  29 with Casing;   use Casing;
  30 with Checks;   use Checks;
  31 with Einfo;    use Einfo;
  32 with Errout;   use Errout;
  33 with Eval_Fat;
  34 with Exp_Dist; use Exp_Dist;
  35 with Exp_Util; use Exp_Util;
  36 with Expander; use Expander;
  37 with Freeze;   use Freeze;
  38 with Gnatvsn;  use Gnatvsn;
  39 with Itypes;   use Itypes;
  40 with Lib;      use Lib;
  41 with Lib.Xref; use Lib.Xref;
  42 with Nlists;   use Nlists;
  43 with Nmake;    use Nmake;
  44 with Opt;      use Opt;
  45 with Restrict; use Restrict;
  46 with Rident;   use Rident;
  47 with Rtsfind;  use Rtsfind;
  48 with Sdefault; use Sdefault;
  49 with Sem;      use Sem;
  50 with Sem_Aux;  use Sem_Aux;
  51 with Sem_Cat;  use Sem_Cat;
  52 with Sem_Ch6;  use Sem_Ch6;
  53 with Sem_Ch8;  use Sem_Ch8;
  54 with Sem_Ch10; use Sem_Ch10;
  55 with Sem_Dist; use Sem_Dist;
  56 with Sem_Elim; use Sem_Elim;
  57 with Sem_Eval; use Sem_Eval;
  58 with Sem_Res;  use Sem_Res;
  59 with Sem_Type; use Sem_Type;
  60 with Sem_Util; use Sem_Util;
  61 with Stand;    use Stand;
  62 with Sinfo;    use Sinfo;
  63 with Sinput;   use Sinput;
  64 with Stringt;  use Stringt;
  65 with Style;
  66 with Stylesw;  use Stylesw;
  67 with Targparm; use Targparm;
  68 with Ttypes;   use Ttypes;
  69 with Ttypef;   use Ttypef;
  70 with Tbuild;   use Tbuild;
  71 with Uintp;    use Uintp;
  72 with Urealp;   use Urealp;
  73
  74 package body Sem_Attr is
  75
  76    True_Value  : constant Uint := Uint_1;
  77    False_Value : constant Uint := Uint_0;
  78    --  Synonyms to be used when these constants are used as Boolean values
  79
  80    Bad_Attribute : exception;
  81    --  Exception raised if an error is detected during attribute processing,
  82    --  used so that we can abandon the processing so we don't run into
  83    --  trouble with cascaded errors.
  84
  85    --  The following array is the list of attributes defined in the Ada 83 RM
  86    --  that are not included in Ada 95, but still get recognized in GNAT.
  87
  88    Attribute_83 : constant Attribute_Class_Array := Attribute_Class_Array'(
  89       Attribute_Address           |
  90       Attribute_Aft               |
  91       Attribute_Alignment         |
  92       Attribute_Base              |
  93       Attribute_Callable          |
  94       Attribute_Constrained       |
  95       Attribute_Count             |
  96       Attribute_Delta             |
  97       Attribute_Digits            |
  98       Attribute_Emax              |
  99       Attribute_Epsilon           |
 100       Attribute_First             |
 101       Attribute_First_Bit         |
 102       Attribute_Fore              |
 103       Attribute_Image             |
 104       Attribute_Large             |
 105       Attribute_Last              |
 106       Attribute_Last_Bit          |
 107       Attribute_Leading_Part      |
 108       Attribute_Length            |
 109       Attribute_Machine_Emax      |
 110       Attribute_Machine_Emin      |
 111       Attribute_Machine_Mantissa  |
 112       Attribute_Machine_Overflows |
 113       Attribute_Machine_Radix     |
 114       Attribute_Machine_Rounds    |
 115       Attribute_Mantissa          |
 116       Attribute_Pos               |
 117       Attribute_Position          |
 118       Attribute_Pred              |
 119       Attribute_Range             |
 120       Attribute_Safe_Emax         |
 121       Attribute_Safe_Large        |
 122       Attribute_Safe_Small        |
 123       Attribute_Size              |
 124       Attribute_Small             |
 125       Attribute_Storage_Size      |
 126       Attribute_Succ              |
 127       Attribute_Terminated        |
 128       Attribute_Val               |
 129       Attribute_Value             |
 130       Attribute_Width             => True,
 131       others                      => False);
 132
 133    --  The following array is the list of attributes defined in the Ada 2005
 134    --  RM which are not defined in Ada 95. These are recognized in Ada 95 mode,
 135    --  but in Ada 95 they are considered to be implementation defined.
 136
 137    Attribute_05 : constant Attribute_Class_Array := Attribute_Class_Array'(
 138       Attribute_Machine_Rounding  |
 139       Attribute_Priority          |
 140       Attribute_Stream_Size       |
 141       Attribute_Wide_Wide_Width   => True,
 142       others                      => False);
 143
 144    --  The following array contains all attributes that imply a modification
 145    --  of their prefixes or result in an access value. Such prefixes can be
 146    --  considered as lvalues.
 147
 148    Attribute_Name_Implies_Lvalue_Prefix : constant Attribute_Class_Array :=
 149       Attribute_Class_Array'(
 150       Attribute_Access              |
 151       Attribute_Address             |
 152       Attribute_Input               |
 153       Attribute_Read                |
 154       Attribute_Unchecked_Access    |
 155       Attribute_Unrestricted_Access => True,
 156       others                        => False);
 157
 158    -----------------------
 159    -- Local_Subprograms --
 160    -----------------------
 161
 162    procedure Eval_Attribute (N : Node_Id);
 163    --  Performs compile time evaluation of attributes where possible, leaving
 164    --  the Is_Static_Expression/Raises_Constraint_Error flags appropriately
 165    --  set, and replacing the node with a literal node if the value can be
 166    --  computed at compile time. All static attribute references are folded,
 167    --  as well as a number of cases of non-static attributes that can always
 168    --  be computed at compile time (e.g. floating-point model attributes that
 169    --  are applied to non-static subtypes). Of course in such cases, the
 170    --  Is_Static_Expression flag will not be set on the resulting literal.
 171    --  Note that the only required action of this procedure is to catch the
 172    --  static expression cases as described in the RM. Folding of other cases
 173    --  is done where convenient, but some additional non-static folding is in
 174    --  N_Expand_Attribute_Reference in cases where this is more convenient.
 175
 176    function Is_Anonymous_Tagged_Base
 177      (Anon : Entity_Id;
 178       Typ  : Entity_Id)
 179       return Boolean;
 180    --  For derived tagged types that constrain parent discriminants we build
 181    --  an anonymous unconstrained base type. We need to recognize the relation
 182    --  between the two when analyzing an access attribute for a constrained
 183    --  component, before the full declaration for Typ has been analyzed, and
 184    --  where therefore the prefix of the attribute does not match the enclosing
 185    --  scope.
 186
 187    -----------------------
 188    -- Analyze_Attribute --
 189    -----------------------
 190
 191    procedure Analyze_Attribute (N : Node_Id) is
 192       Loc     : constant Source_Ptr   := Sloc (N);
 193       Aname   : constant Name_Id      := Attribute_Name (N);
 194       P       : constant Node_Id      := Prefix (N);
 195       Exprs   : constant List_Id      := Expressions (N);
 196       Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
 197       E1      : Node_Id;
 198       E2      : Node_Id;
 199
 200       P_Type : Entity_Id;
 201       --  Type of prefix after analysis
 202
 203       P_Base_Type : Entity_Id;
 204       --  Base type of prefix after analysis
 205
 206       -----------------------
 207       -- Local Subprograms --
 208       -----------------------
 209
 210       procedure Analyze_Access_Attribute;
 211       --  Used for Access, Unchecked_Access, Unrestricted_Access attributes.
 212       --  Internally, Id distinguishes which of the three cases is involved.
 213
 214       procedure Check_Array_Or_Scalar_Type;
 215       --  Common procedure used by First, Last, Range attribute to check
 216       --  that the prefix is a constrained array or scalar type, or a name
 217       --  of an array object, and that an argument appears only if appropriate
 218       --  (i.e. only in the array case).
 219
 220       procedure Check_Array_Type;
 221       --  Common semantic checks for all array attributes. Checks that the
 222       --  prefix is a constrained array type or the name of an array object.
 223       --  The error message for non-arrays is specialized appropriately.
 224
 225       procedure Check_Asm_Attribute;
 226       --  Common semantic checks for Asm_Input and Asm_Output attributes
 227
 228       procedure Check_Component;
 229       --  Common processing for Bit_Position, First_Bit, Last_Bit, and
 230       --  Position. Checks prefix is an appropriate selected component.
 231
 232       procedure Check_Decimal_Fixed_Point_Type;
 233       --  Check that prefix of attribute N is a decimal fixed-point type
 234
 235       procedure Check_Dereference;
 236       --  If the prefix of attribute is an object of an access type, then
 237       --  introduce an explicit dereference, and adjust P_Type accordingly.
 238
 239       procedure Check_Discrete_Type;
 240       --  Verify that prefix of attribute N is a discrete type
 241
 242       procedure Check_E0;
 243       --  Check that no attribute arguments are present
 244
 245       procedure Check_Either_E0_Or_E1;
 246       --  Check that there are zero or one attribute arguments present
 247
 248       procedure Check_E1;
 249       --  Check that exactly one attribute argument is present
 250
 251       procedure Check_E2;
 252       --  Check that two attribute arguments are present
 253
 254       procedure Check_Enum_Image;
 255       --  If the prefix type is an enumeration type, set all its literals
 256       --  as referenced, since the image function could possibly end up
 257       --  referencing any of the literals indirectly. Same for Enum_Val.
 258
 259       procedure Check_Fixed_Point_Type;
 260       --  Verify that prefix of attribute N is a fixed type
 261
 262       procedure Check_Fixed_Point_Type_0;
 263       --  Verify that prefix of attribute N is a fixed type and that
 264       --  no attribute expressions are present
 265
 266       procedure Check_Floating_Point_Type;
 267       --  Verify that prefix of attribute N is a float type
 268
 269       procedure Check_Floating_Point_Type_0;
 270       --  Verify that prefix of attribute N is a float type and that
 271       --  no attribute expressions are present
 272
 273       procedure Check_Floating_Point_Type_1;
 274       --  Verify that prefix of attribute N is a float type and that
 275       --  exactly one attribute expression is present
 276
 277       procedure Check_Floating_Point_Type_2;
 278       --  Verify that prefix of attribute N is a float type and that
 279       --  two attribute expressions are present
 280
 281       procedure Legal_Formal_Attribute;
 282       --  Common processing for attributes Definite and Has_Discriminants.
 283       --  Checks that prefix is generic indefinite formal type.
 284
 285       procedure Check_Integer_Type;
 286       --  Verify that prefix of attribute N is an integer type
 287
 288       procedure Check_Library_Unit;
 289       --  Verify that prefix of attribute N is a library unit
 290
 291       procedure Check_Modular_Integer_Type;
 292       --  Verify that prefix of attribute N is a modular integer type
 293
 294       procedure Check_Not_CPP_Type;
 295       --  Check that P (the prefix of the attribute) is not an CPP type
 296       --  for which no Ada predefined primitive is available.
 297
 298       procedure Check_Not_Incomplete_Type;
 299       --  Check that P (the prefix of the attribute) is not an incomplete
 300       --  type or a private type for which no full view has been given.
 301
 302       procedure Check_Object_Reference (P : Node_Id);
 303       --  Check that P (the prefix of the attribute) is an object reference
 304
 305       procedure Check_Program_Unit;
 306       --  Verify that prefix of attribute N is a program unit
 307
 308       procedure Check_Real_Type;
 309       --  Verify that prefix of attribute N is fixed or float type
 310
 311       procedure Check_Scalar_Type;
 312       --  Verify that prefix of attribute N is a scalar type
 313
 314       procedure Check_Standard_Prefix;
 315       --  Verify that prefix of attribute N is package Standard
 316
 317       procedure Check_Stream_Attribute (Nam : TSS_Name_Type);
 318       --  Validity checking for stream attribute. Nam is the TSS name of the
 319       --  corresponding possible defined attribute function (e.g. for the
 320       --  Read attribute, Nam will be TSS_Stream_Read).
 321
 322       procedure Check_PolyORB_Attribute;
 323       --  Validity checking for PolyORB/DSA attribute
 324
 325       procedure Check_Task_Prefix;
 326       --  Verify that prefix of attribute N is a task or task type
 327
 328       procedure Check_Type;
 329       --  Verify that the prefix of attribute N is a type
 330
 331       procedure Check_Unit_Name (Nod : Node_Id);
 332       --  Check that Nod is of the form of a library unit name, i.e that
 333       --  it is an identifier, or a selected component whose prefix is
 334       --  itself of the form of a library unit name. Note that this is
 335       --  quite different from Check_Program_Unit, since it only checks
 336       --  the syntactic form of the name, not the semantic identity. This
 337       --  is because it is used with attributes (Elab_Body, Elab_Spec, and
 338       --  UET_Address) which can refer to non-visible unit.
 339
 340       procedure Error_Attr (Msg : String; Error_Node : Node_Id);
 341       pragma No_Return (Error_Attr);
 342       procedure Error_Attr;
 343       pragma No_Return (Error_Attr);
 344       --  Posts error using Error_Msg_N at given node, sets type of attribute
 345       --  node to Any_Type, and then raises Bad_Attribute to avoid any further
 346       --  semantic processing. The message typically contains a % insertion
 347       --  character which is replaced by the attribute name. The call with
 348       --  no arguments is used when the caller has already generated the
 349       --  required error messages.
 350
 351       procedure Error_Attr_P (Msg : String);
 352       pragma No_Return (Error_Attr);
 353       --  Like Error_Attr, but error is posted at the start of the prefix
 354
 355       procedure Standard_Attribute (Val : Int);
 356       --  Used to process attributes whose prefix is package Standard which
 357       --  yield values of type Universal_Integer. The attribute reference
 358       --  node is rewritten with an integer literal of the given value.
 359
 360       procedure Unexpected_Argument (En : Node_Id);
 361       --  Signal unexpected attribute argument (En is the argument)
 362
 363       procedure Validate_Non_Static_Attribute_Function_Call;
 364       --  Called when processing an attribute that is a function call to a
 365       --  non-static function, i.e. an attribute function that either takes
 366       --  non-scalar arguments or returns a non-scalar result. Verifies that
 367       --  such a call does not appear in a preelaborable context.
 368
 369       ------------------------------
 370       -- Analyze_Access_Attribute --
 371       ------------------------------
 372
 373       procedure Analyze_Access_Attribute is
 374          Acc_Type : Entity_Id;
 375
 376          Scop : Entity_Id;
 377          Typ  : Entity_Id;
 378
 379          function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id;
 380          --  Build an access-to-object type whose designated type is DT,
 381          --  and whose Ekind is appropriate to the attribute type. The
 382          --  type that is constructed is returned as the result.
 383
 384          procedure Build_Access_Subprogram_Type (P : Node_Id);
 385          --  Build an access to subprogram whose designated type is the type of
 386          --  the prefix. If prefix is overloaded, so is the node itself. The
 387          --  result is stored in Acc_Type.
 388
 389          function OK_Self_Reference return Boolean;
 390          --  An access reference whose prefix is a type can legally appear
 391          --  within an aggregate, where it is obtained by expansion of
 392          --  a defaulted aggregate. The enclosing aggregate that contains
 393          --  the self-referenced is flagged so that the self-reference can
 394          --  be expanded into a reference to the target object (see exp_aggr).
 395
 396          ------------------------------
 397          -- Build_Access_Object_Type --
 398          ------------------------------
 399
 400          function Build_Access_Object_Type (DT : Entity_Id) return Entity_Id is
 401             Typ : constant Entity_Id :=
 402                     New_Internal_Entity
 403                       (E_Access_Attribute_Type, Current_Scope, Loc, 'A');
 404          begin
 405             Set_Etype                     (Typ, Typ);
 406             Set_Is_Itype                  (Typ);
 407             Set_Associated_Node_For_Itype (Typ, N);
 408             Set_Directly_Designated_Type  (Typ, DT);
 409             return Typ;
 410          end Build_Access_Object_Type;
 411
 412          ----------------------------------
 413          -- Build_Access_Subprogram_Type --
 414          ----------------------------------
 415
 416          procedure Build_Access_Subprogram_Type (P : Node_Id) is
 417             Index : Interp_Index;
 418             It    : Interp;
 419
 420             procedure Check_Local_Access (E : Entity_Id);
 421             --  Deal with possible access to local subprogram. If we have such
 422             --  an access, we set a flag to kill all tracked values on any call
 423             --  because this access value may be passed around, and any called
 424             --  code might use it to access a local procedure which clobbers a
 425             --  tracked value. If the scope is a loop or block, indicate that
 426             --  value tracking is disabled for the enclosing subprogram.
 427
 428             function Get_Kind (E : Entity_Id) return Entity_Kind;
 429             --  Distinguish between access to regular/protected subprograms
 430
 431             ------------------------
 432             -- Check_Local_Access --
 433             ------------------------
 434
 435             procedure Check_Local_Access (E : Entity_Id) is
 436             begin
 437                if not Is_Library_Level_Entity (E) then
 438                   Set_Suppress_Value_Tracking_On_Call (Current_Scope);
 439                   Set_Suppress_Value_Tracking_On_Call
 440                     (Nearest_Dynamic_Scope (Current_Scope));
 441                end if;
 442             end Check_Local_Access;
 443
 444             --------------
 445             -- Get_Kind --
 446             --------------
 447
 448             function Get_Kind (E : Entity_Id) return Entity_Kind is
 449             begin
 450                if Convention (E) = Convention_Protected then
 451                   return E_Access_Protected_Subprogram_Type;
 452                else
 453                   return E_Access_Subprogram_Type;
 454                end if;
 455             end Get_Kind;
 456
 457          --  Start of processing for Build_Access_Subprogram_Type
 458
 459          begin
 460             --  In the case of an access to subprogram, use the name of the
 461             --  subprogram itself as the designated type. Type-checking in
 462             --  this case compares the signatures of the designated types.
 463
 464             --  Note: This fragment of the tree is temporarily malformed
 465             --  because the correct tree requires an E_Subprogram_Type entity
 466             --  as the designated type. In most cases this designated type is
 467             --  later overridden by the semantics with the type imposed by the
 468             --  context during the resolution phase. In the specific case of
 469             --  the expression Address!(Prim'Unrestricted_Access), used to
 470             --  initialize slots of dispatch tables, this work will be done by
 471             --  the expander (see Exp_Aggr).
 472
 473             --  The reason to temporarily add this kind of node to the tree
 474             --  instead of a proper E_Subprogram_Type itype, is the following:
 475             --  in case of errors found in the source file we report better
 476             --  error messages. For example, instead of generating the
 477             --  following error:
 478
 479             --      "expected access to subprogram with profile
 480             --       defined at line X"
 481
 482             --  we currently generate:
 483
 484             --      "expected access to function Z defined at line X"
 485
 486             Set_Etype (N, Any_Type);
 487
 488             if not Is_Overloaded (P) then
 489                Check_Local_Access (Entity (P));
 490
 491                if not Is_Intrinsic_Subprogram (Entity (P)) then
 492                   Acc_Type := Create_Itype (Get_Kind (Entity (P)), N);
 493                   Set_Is_Public (Acc_Type, False);
 494                   Set_Etype (Acc_Type, Acc_Type);
 495                   Set_Convention (Acc_Type, Convention (Entity (P)));
 496                   Set_Directly_Designated_Type (Acc_Type, Entity (P));
 497                   Set_Etype (N, Acc_Type);
 498                   Freeze_Before (N, Acc_Type);
 499                end if;
 500
 501             else
 502                Get_First_Interp (P, Index, It);
 503                while Present (It.Nam) loop
 504                   Check_Local_Access (It.Nam);
 505
 506                   if not Is_Intrinsic_Subprogram (It.Nam) then
 507                      Acc_Type := Create_Itype (Get_Kind (It.Nam), N);
 508                      Set_Is_Public (Acc_Type, False);
 509                      Set_Etype (Acc_Type, Acc_Type);
 510                      Set_Convention (Acc_Type, Convention (It.Nam));
 511                      Set_Directly_Designated_Type (Acc_Type, It.Nam);
 512                      Add_One_Interp (N, Acc_Type, Acc_Type);
 513                      Freeze_Before (N, Acc_Type);
 514                   end if;
 515
 516                   Get_Next_Interp (Index, It);
 517                end loop;
 518             end if;
 519
 520             --  Cannot be applied to intrinsic. Looking at the tests above,
 521             --  the only way Etype (N) can still be set to Any_Type is if
 522             --  Is_Intrinsic_Subprogram was True for some referenced entity.
 523
 524             if Etype (N) = Any_Type then
 525                Error_Attr_P ("prefix of % attribute cannot be intrinsic");
 526             end if;
 527          end Build_Access_Subprogram_Type;
 528
 529          ----------------------
 530          -- OK_Self_Reference --
 531          ----------------------
 532
 533          function OK_Self_Reference return Boolean is
 534             Par : Node_Id;
 535
 536          begin
 537             Par := Parent (N);
 538             while Present (Par)
 539               and then
 540                (Nkind (Par) = N_Component_Association
 541                  or else Nkind (Par) in N_Subexpr)
 542             loop
 543                if Nkind_In (Par, N_Aggregate, N_Extension_Aggregate) then
 544                   if Etype (Par) = Typ then
 545                      Set_Has_Self_Reference (Par);
 546                      return True;
 547                   end if;
 548                end if;
 549
 550                Par := Parent (Par);
 551             end loop;
 552
 553             --  No enclosing aggregate, or not a self-reference
 554
 555             return False;
 556          end OK_Self_Reference;
 557
 558       --  Start of processing for Analyze_Access_Attribute
 559
 560       begin
 561          Check_E0;
 562
 563          if Nkind (P) = N_Character_Literal then
 564             Error_Attr_P
 565               ("prefix of % attribute cannot be enumeration literal");
 566          end if;
 567
 568          --  Case of access to subprogram
 569
 570          if Is_Entity_Name (P)
 571            and then Is_Overloadable (Entity (P))
 572          then
 573             if Has_Pragma_Inline_Always (Entity (P)) then
 574                Error_Attr_P
 575                  ("prefix of % attribute cannot be Inline_Always subprogram");
 576             end if;
 577
 578             if Aname = Name_Unchecked_Access then
 579                Error_Attr ("attribute% cannot be applied to a subprogram", P);
 580             end if;
 581
 582             --  Issue an error if the prefix denotes an eliminated subprogram
 583
 584             Check_For_Eliminated_Subprogram (P, Entity (P));
 585
 586             --  Build the appropriate subprogram type
 587
 588             Build_Access_Subprogram_Type (P);
 589
 590             --  For unrestricted access, kill current values, since this
 591             --  attribute allows a reference to a local subprogram that
 592             --  could modify local variables to be passed out of scope
 593
 594             if Aname = Name_Unrestricted_Access then
 595
 596                --  Do not kill values on nodes initializing dispatch tables
 597                --  slots. The construct Prim_Ptr!(Prim'Unrestricted_Access)
 598                --  is currently generated by the expander only for this
 599                --  purpose. Done to keep the quality of warnings currently
 600                --  generated by the compiler (otherwise any declaration of
 601                --  a tagged type cleans constant indications from its scope).
 602
 603                if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
 604                  and then (Etype (Parent (N)) = RTE (RE_Prim_Ptr)
 605                              or else
 606                            Etype (Parent (N)) = RTE (RE_Size_Ptr))
 607                  and then Is_Dispatching_Operation
 608                             (Directly_Designated_Type (Etype (N)))
 609                then
 610                   null;
 611                else
 612                   Kill_Current_Values;
 613                end if;
 614             end if;
 615
 616             return;
 617
 618          --  Component is an operation of a protected type
 619
 620          elsif Nkind (P) = N_Selected_Component
 621            and then Is_Overloadable (Entity (Selector_Name (P)))
 622          then
 623             if Ekind (Entity (Selector_Name (P))) = E_Entry then
 624                Error_Attr_P ("prefix of % attribute must be subprogram");
 625             end if;
 626
 627             Build_Access_Subprogram_Type (Selector_Name (P));
 628             return;
 629          end if;
 630
 631          --  Deal with incorrect reference to a type, but note that some
 632          --  accesses are allowed: references to the current type instance,
 633          --  or in Ada 2005 self-referential pointer in a default-initialized
 634          --  aggregate.
 635
 636          if Is_Entity_Name (P) then
 637             Typ := Entity (P);
 638
 639             --  The reference may appear in an aggregate that has been expanded
 640             --  into a loop. Locate scope of type definition, if any.
 641
 642             Scop := Current_Scope;
 643             while Ekind (Scop) = E_Loop loop
 644                Scop := Scope (Scop);
 645             end loop;
 646
 647             if Is_Type (Typ) then
 648
 649                --  OK if we are within the scope of a limited type
 650                --  let's mark the component as having per object constraint
 651
 652                if Is_Anonymous_Tagged_Base (Scop, Typ) then
 653                   Typ := Scop;
 654                   Set_Entity (P, Typ);
 655                   Set_Etype  (P, Typ);
 656                end if;
 657
 658                if Typ = Scop then
 659                   declare
 660                      Q : Node_Id := Parent (N);
 661
 662                   begin
 663                      while Present (Q)
 664                        and then Nkind (Q) /= N_Component_Declaration
 665                      loop
 666                         Q := Parent (Q);
 667                      end loop;
 668
 669                      if Present (Q) then
 670                         Set_Has_Per_Object_Constraint
 671                           (Defining_Identifier (Q), True);
 672                      end if;
 673                   end;
 674
 675                   if Nkind (P) = N_Expanded_Name then
 676                      Error_Msg_F
 677                        ("current instance prefix must be a direct name", P);
 678                   end if;
 679
 680                   --  If a current instance attribute appears in a component
 681                   --  constraint it must appear alone; other contexts (spec-
 682                   --  expressions, within a task body) are not subject to this
 683                   --  restriction.
 684
 685                   if not In_Spec_Expression
 686                     and then not Has_Completion (Scop)
 687                     and then not
 688                       Nkind_In (Parent (N), N_Discriminant_Association,
 689                                             N_Index_Or_Discriminant_Constraint)
 690                   then
 691                      Error_Msg_N
 692                        ("current instance attribute must appear alone", N);
 693                   end if;
 694
 695                --  OK if we are in initialization procedure for the type
 696                --  in question, in which case the reference to the type
 697                --  is rewritten as a reference to the current object.
 698
 699                elsif Ekind (Scop) = E_Procedure
 700                  and then Is_Init_Proc (Scop)
 701                  and then Etype (First_Formal (Scop)) = Typ
 702                then
 703                   Rewrite (N,
 704                     Make_Attribute_Reference (Loc,
 705                       Prefix         => Make_Identifier (Loc, Name_uInit),
 706                       Attribute_Name => Name_Unrestricted_Access));
 707                   Analyze (N);
 708                   return;
 709
 710                --  OK if a task type, this test needs sharpening up ???
 711
 712                elsif Is_Task_Type (Typ) then
 713                   null;
 714
 715                --  OK if self-reference in an aggregate in Ada 2005, and
 716                --  the reference comes from a copied default expression.
 717
 718                --  Note that we check legality of self-reference even if the
 719                --  expression comes from source, e.g. when a single component
 720                --  association in an aggregate has a box association.
 721
 722                elsif Ada_Version >= Ada_05
 723                  and then OK_Self_Reference
 724                then
 725                   null;
 726
 727                --  OK if reference to current instance of a protected object
 728
 729                elsif Is_Protected_Self_Reference (P) then
 730                   null;
 731
 732                --  Otherwise we have an error case
 733
 734                else
 735                   Error_Attr ("% attribute cannot be applied to type", P);
 736                   return;
 737                end if;
 738             end if;
 739          end if;
 740
 741          --  If we fall through, we have a normal access to object case.
 742          --  Unrestricted_Access is legal wherever an allocator would be
 743          --  legal, so its Etype is set to E_Allocator. The expected type
 744          --  of the other attributes is a general access type, and therefore
 745          --  we label them with E_Access_Attribute_Type.
 746
 747          if not Is_Overloaded (P) then
 748             Acc_Type := Build_Access_Object_Type (P_Type);
 749             Set_Etype (N, Acc_Type);
 750          else
 751             declare
 752                Index : Interp_Index;
 753                It    : Interp;
 754             begin
 755                Set_Etype (N, Any_Type);
 756                Get_First_Interp (P, Index, It);
 757                while Present (It.Typ) loop
 758                   Acc_Type := Build_Access_Object_Type (It.Typ);
 759                   Add_One_Interp (N, Acc_Type, Acc_Type);
 760                   Get_Next_Interp (Index, It);
 761                end loop;
 762             end;
 763          end if;
 764
 765          --  Special cases when we can find a prefix that is an entity name
 766
 767          declare
 768             PP  : Node_Id;
 769             Ent : Entity_Id;
 770
 771          begin
 772             PP := P;
 773             loop
 774                if Is_Entity_Name (PP) then
 775                   Ent := Entity (PP);
 776
 777                   --  If we have an access to an object, and the attribute
 778                   --  comes from source, then set the object as potentially
 779                   --  source modified. We do this because the resulting access
 780                   --  pointer can be used to modify the variable, and we might
 781                   --  not detect this, leading to some junk warnings.
 782
 783                   Set_Never_Set_In_Source (Ent, False);
 784
 785                   --  Mark entity as address taken, and kill current values
 786
 787                   Set_Address_Taken (Ent);
 788                   Kill_Current_Values (Ent);
 789                   exit;
 790
 791                elsif Nkind_In (PP, N_Selected_Component,
 792                                    N_Indexed_Component)
 793                then
 794                   PP := Prefix (PP);
 795
 796                else
 797                   exit;
 798                end if;
 799             end loop;
 800          end;
 801
 802          --  Check for aliased view unless unrestricted case. We allow a
 803          --  nonaliased prefix when within an instance because the prefix may
 804          --  have been a tagged formal object, which is defined to be aliased
 805          --  even when the actual might not be (other instance cases will have
 806          --  been caught in the generic). Similarly, within an inlined body we
 807          --  know that the attribute is legal in the original subprogram, and
 808          --  therefore legal in the expansion.
 809
 810          if Aname /= Name_Unrestricted_Access
 811            and then not Is_Aliased_View (P)
 812            and then not In_Instance
 813            and then not In_Inlined_Body
 814          then
 815             Error_Attr_P ("prefix of % attribute must be aliased");
 816          end if;
 817       end Analyze_Access_Attribute;
 818
 819       --------------------------------
 820       -- Check_Array_Or_Scalar_Type --
 821       --------------------------------
 822
 823       procedure Check_Array_Or_Scalar_Type is
 824          Index : Entity_Id;
 825
 826          D : Int;
 827          --  Dimension number for array attributes
 828
 829       begin
 830          --  Case of string literal or string literal subtype. These cases
 831          --  cannot arise from legal Ada code, but the expander is allowed
 832          --  to generate them. They require special handling because string
 833          --  literal subtypes do not have standard bounds (the whole idea
 834          --  of these subtypes is to avoid having to generate the bounds)
 835
 836          if Ekind (P_Type) = E_String_Literal_Subtype then
 837             Set_Etype (N, Etype (First_Index (P_Base_Type)));
 838             return;
 839
 840          --  Scalar types
 841
 842          elsif Is_Scalar_Type (P_Type) then
 843             Check_Type;
 844
 845             if Present (E1) then
 846                Error_Attr ("invalid argument in % attribute", E1);
 847             else
 848                Set_Etype (N, P_Base_Type);
 849                return;
 850             end if;
 851
 852          --  The following is a special test to allow 'First to apply to
 853          --  private scalar types if the attribute comes from generated
 854          --  code. This occurs in the case of Normalize_Scalars code.
 855
 856          elsif Is_Private_Type (P_Type)
 857            and then Present (Full_View (P_Type))
 858            and then Is_Scalar_Type (Full_View (P_Type))
 859            and then not Comes_From_Source (N)
 860          then
 861             Set_Etype (N, Implementation_Base_Type (P_Type));
 862
 863          --  Array types other than string literal subtypes handled above
 864
 865          else
 866             Check_Array_Type;
 867
 868             --  We know prefix is an array type, or the name of an array
 869             --  object, and that the expression, if present, is static
 870             --  and within the range of the dimensions of the type.
 871
 872             pragma Assert (Is_Array_Type (P_Type));
 873             Index := First_Index (P_Base_Type);
 874
 875             if No (E1) then
 876
 877                --  First dimension assumed
 878
 879                Set_Etype (N, Base_Type (Etype (Index)));
 880
 881             else
 882                D := UI_To_Int (Intval (E1));
 883
 884                for J in 1 .. D - 1 loop
 885                   Next_Index (Index);
 886                end loop;
 887
 888                Set_Etype (N, Base_Type (Etype (Index)));
 889                Set_Etype (E1, Standard_Integer);
 890             end if;
 891          end if;
 892       end Check_Array_Or_Scalar_Type;
 893
 894       ----------------------
 895       -- Check_Array_Type --
 896       ----------------------
 897
 898       procedure Check_Array_Type is
 899          D : Int;
 900          --  Dimension number for array attributes
 901
 902       begin
 903          --  If the type is a string literal type, then this must be generated
 904          --  internally, and no further check is required on its legality.
 905
 906          if Ekind (P_Type) = E_String_Literal_Subtype then
 907             return;
 908
 909          --  If the type is a composite, it is an illegal aggregate, no point
 910          --  in going on.
 911
 912          elsif P_Type = Any_Composite then
 913             raise Bad_Attribute;
 914          end if;
 915
 916          --  Normal case of array type or subtype
 917
 918          Check_Either_E0_Or_E1;
 919          Check_Dereference;
 920
 921          if Is_Array_Type (P_Type) then
 922             if not Is_Constrained (P_Type)
 923               and then Is_Entity_Name (P)
 924               and then Is_Type (Entity (P))
 925             then
 926                --  Note: we do not call Error_Attr here, since we prefer to
 927                --  continue, using the relevant index type of the array,
 928                --  even though it is unconstrained. This gives better error
 929                --  recovery behavior.
 930
 931                Error_Msg_Name_1 := Aname;
 932                Error_Msg_F
 933                  ("prefix for % attribute must be constrained array", P);
 934             end if;
 935
 936             D := Number_Dimensions (P_Type);
 937
 938          else
 939             if Is_Private_Type (P_Type) then
 940                Error_Attr_P ("prefix for % attribute may not be private type");
 941
 942             elsif Is_Access_Type (P_Type)
 943               and then Is_Array_Type (Designated_Type (P_Type))
 944               and then Is_Entity_Name (P)
 945               and then Is_Type (Entity (P))
 946             then
 947                Error_Attr_P ("prefix of % attribute cannot be access type");
 948
 949             elsif Attr_Id = Attribute_First
 950                     or else
 951                   Attr_Id = Attribute_Last
 952             then
 953                Error_Attr ("invalid prefix for % attribute", P);
 954
 955             else
 956                Error_Attr_P ("prefix for % attribute must be array");
 957             end if;
 958          end if;
 959
 960          if Present (E1) then
 961             Resolve (E1, Any_Integer);
 962             Set_Etype (E1, Standard_Integer);
 963
 964             if not Is_Static_Expression (E1)
 965               or else Raises_Constraint_Error (E1)
 966             then
 967                Flag_Non_Static_Expr
 968                  ("expression for dimension must be static!", E1);
 969                Error_Attr;
 970
 971             elsif  UI_To_Int (Expr_Value (E1)) > D
 972               or else UI_To_Int (Expr_Value (E1)) < 1
 973             then
 974                Error_Attr ("invalid dimension number for array type", E1);
 975             end if;
 976          end if;
 977
 978          if (Style_Check and Style_Check_Array_Attribute_Index)
 979            and then Comes_From_Source (N)
 980          then
 981             Style.Check_Array_Attribute_Index (N, E1, D);
 982          end if;
 983       end Check_Array_Type;
 984
 985       -------------------------
 986       -- Check_Asm_Attribute --
 987       -------------------------
 988
 989       procedure Check_Asm_Attribute is
 990       begin
 991          Check_Type;
 992          Check_E2;
 993
 994          --  Check first argument is static string expression
 995
 996          Analyze_And_Resolve (E1, Standard_String);
 997
 998          if Etype (E1) = Any_Type then
 999             return;
1000
1001          elsif not Is_OK_Static_Expression (E1) then
1002             Flag_Non_Static_Expr
1003               ("constraint argument must be static string expression!", E1);
1004             Error_Attr;
1005          end if;
1006
1007          --  Check second argument is right type
1008
1009          Analyze_And_Resolve (E2, Entity (P));
1010
1011          --  Note: that is all we need to do, we don't need to check
1012          --  that it appears in a correct context. The Ada type system
1013          --  will do that for us.
1014
1015       end Check_Asm_Attribute;
1016
1017       ---------------------
1018       -- Check_Component --
1019       ---------------------
1020
1021       procedure Check_Component is
1022       begin
1023          Check_E0;
1024
1025          if Nkind (P) /= N_Selected_Component
1026            or else
1027              (Ekind (Entity (Selector_Name (P))) /= E_Component
1028                and then
1029               Ekind (Entity (Selector_Name (P))) /= E_Discriminant)
1030          then
1031             Error_Attr_P ("prefix for % attribute must be selected component");
1032          end if;
1033       end Check_Component;
1034
1035       ------------------------------------
1036       -- Check_Decimal_Fixed_Point_Type --
1037       ------------------------------------
1038
1039       procedure Check_Decimal_Fixed_Point_Type is
1040       begin
1041          Check_Type;
1042
1043          if not Is_Decimal_Fixed_Point_Type (P_Type) then
1044             Error_Attr_P ("prefix of % attribute must be decimal type");
1045          end if;
1046       end Check_Decimal_Fixed_Point_Type;
1047
1048       -----------------------
1049       -- Check_Dereference --
1050       -----------------------
1051
1052       procedure Check_Dereference is
1053       begin
1054
1055          --  Case of a subtype mark
1056
1057          if Is_Entity_Name (P)
1058            and then Is_Type (Entity (P))
1059          then
1060             return;
1061          end if;
1062
1063          --  Case of an expression
1064
1065          Resolve (P);
1066
1067          if Is_Access_Type (P_Type) then
1068
1069             --  If there is an implicit dereference, then we must freeze
1070             --  the designated type of the access type, since the type of
1071             --  the referenced array is this type (see AI95-00106).
1072
1073             --  As done elsewhere, freezing must not happen when pre-analyzing
1074             --  a pre- or postcondition or a default value for an object or
1075             --  for a formal parameter.
1076
1077             if not In_Spec_Expression then
1078                Freeze_Before (N, Designated_Type (P_Type));
1079             end if;
1080
1081             Rewrite (P,
1082               Make_Explicit_Dereference (Sloc (P),
1083                 Prefix => Relocate_Node (P)));
1084
1085             Analyze_And_Resolve (P);
1086             P_Type := Etype (P);
1087
1088             if P_Type = Any_Type then
1089                raise Bad_Attribute;
1090             end if;
1091
1092             P_Base_Type := Base_Type (P_Type);
1093          end if;
1094       end Check_Dereference;
1095
1096       -------------------------
1097       -- Check_Discrete_Type --
1098       -------------------------
1099
1100       procedure Check_Discrete_Type is
1101       begin
1102          Check_Type;
1103
1104          if not Is_Discrete_Type (P_Type) then
1105             Error_Attr_P ("prefix of % attribute must be discrete type");
1106          end if;
1107       end Check_Discrete_Type;
1108
1109       --------------
1110       -- Check_E0 --
1111       --------------
1112
1113       procedure Check_E0 is
1114       begin
1115          if Present (E1) then
1116             Unexpected_Argument (E1);
1117          end if;
1118       end Check_E0;
1119
1120       --------------
1121       -- Check_E1 --
1122       --------------
1123
1124       procedure Check_E1 is
1125       begin
1126          Check_Either_E0_Or_E1;
1127
1128          if No (E1) then
1129
1130             --  Special-case attributes that are functions and that appear as
1131             --  the prefix of another attribute. Error is posted on parent.
1132
1133             if Nkind (Parent (N)) = N_Attribute_Reference
1134               and then (Attribute_Name (Parent (N)) = Name_Address
1135                           or else
1136                         Attribute_Name (Parent (N)) = Name_Code_Address
1137                           or else
1138                         Attribute_Name (Parent (N)) = Name_Access)
1139             then
1140                Error_Msg_Name_1 := Attribute_Name (Parent (N));
1141                Error_Msg_N ("illegal prefix for % attribute", Parent (N));
1142                Set_Etype (Parent (N), Any_Type);
1143                Set_Entity (Parent (N), Any_Type);
1144                raise Bad_Attribute;
1145
1146             else
1147                Error_Attr ("missing argument for % attribute", N);
1148             end if;
1149          end if;
1150       end Check_E1;
1151
1152       --------------
1153       -- Check_E2 --
1154       --------------
1155
1156       procedure Check_E2 is
1157       begin
1158          if No (E1) then
1159             Error_Attr ("missing arguments for % attribute (2 required)", N);
1160          elsif No (E2) then
1161             Error_Attr ("missing argument for % attribute (2 required)", N);
1162          end if;
1163       end Check_E2;
1164
1165       ---------------------------
1166       -- Check_Either_E0_Or_E1 --
1167       ---------------------------
1168
1169       procedure Check_Either_E0_Or_E1 is
1170       begin
1171          if Present (E2) then
1172             Unexpected_Argument (E2);
1173          end if;
1174       end Check_Either_E0_Or_E1;
1175
1176       ----------------------
1177       -- Check_Enum_Image --
1178       ----------------------
1179
1180       procedure Check_Enum_Image is
1181          Lit : Entity_Id;
1182       begin
1183          if Is_Enumeration_Type (P_Base_Type) then
1184             Lit := First_Literal (P_Base_Type);
1185             while Present (Lit) loop
1186                Set_Referenced (Lit);
1187                Next_Literal (Lit);
1188             end loop;
1189          end if;
1190       end Check_Enum_Image;
1191
1192       ----------------------------
1193       -- Check_Fixed_Point_Type --
1194       ----------------------------
1195
1196       procedure Check_Fixed_Point_Type is
1197       begin
1198          Check_Type;
1199
1200          if not Is_Fixed_Point_Type (P_Type) then
1201             Error_Attr_P ("prefix of % attribute must be fixed point type");
1202          end if;
1203       end Check_Fixed_Point_Type;
1204
1205       ------------------------------
1206       -- Check_Fixed_Point_Type_0 --
1207       ------------------------------
1208
1209       procedure Check_Fixed_Point_Type_0 is
1210       begin
1211          Check_Fixed_Point_Type;
1212          Check_E0;
1213       end Check_Fixed_Point_Type_0;
1214
1215       -------------------------------
1216       -- Check_Floating_Point_Type --
1217       -------------------------------
1218
1219       procedure Check_Floating_Point_Type is
1220       begin
1221          Check_Type;
1222
1223          if not Is_Floating_Point_Type (P_Type) then
1224             Error_Attr_P ("prefix of % attribute must be float type");
1225          end if;
1226       end Check_Floating_Point_Type;
1227
1228       ---------------------------------
1229       -- Check_Floating_Point_Type_0 --
1230       ---------------------------------
1231
1232       procedure Check_Floating_Point_Type_0 is
1233       begin
1234          Check_Floating_Point_Type;
1235          Check_E0;
1236       end Check_Floating_Point_Type_0;
1237
1238       ---------------------------------
1239       -- Check_Floating_Point_Type_1 --
1240       ---------------------------------
1241
1242       procedure Check_Floating_Point_Type_1 is
1243       begin
1244          Check_Floating_Point_Type;
1245          Check_E1;
1246       end Check_Floating_Point_Type_1;
1247
1248       ---------------------------------
1249       -- Check_Floating_Point_Type_2 --
1250       ---------------------------------
1251
1252       procedure Check_Floating_Point_Type_2 is
1253       begin
1254          Check_Floating_Point_Type;
1255          Check_E2;
1256       end Check_Floating_Point_Type_2;
1257
1258       ------------------------
1259       -- Check_Integer_Type --
1260       ------------------------
1261
1262       procedure Check_Integer_Type is
1263       begin
1264          Check_Type;
1265
1266          if not Is_Integer_Type (P_Type) then
1267             Error_Attr_P ("prefix of % attribute must be integer type");
1268          end if;
1269       end Check_Integer_Type;
1270
1271       ------------------------
1272       -- Check_Library_Unit --
1273       ------------------------
1274
1275       procedure Check_Library_Unit is
1276       begin
1277          if not Is_Compilation_Unit (Entity (P)) then
1278             Error_Attr_P ("prefix of % attribute must be library unit");
1279          end if;
1280       end Check_Library_Unit;
1281
1282       --------------------------------
1283       -- Check_Modular_Integer_Type --
1284       --------------------------------
1285
1286       procedure Check_Modular_Integer_Type is
1287       begin
1288          Check_Type;
1289
1290          if not Is_Modular_Integer_Type (P_Type) then
1291             Error_Attr_P
1292               ("prefix of % attribute must be modular integer type");
1293          end if;
1294       end Check_Modular_Integer_Type;
1295
1296       ------------------------
1297       -- Check_Not_CPP_Type --
1298       ------------------------
1299
1300       procedure Check_Not_CPP_Type is
1301       begin
1302          if Is_Tagged_Type (Etype (P))
1303            and then Convention (Etype (P)) = Convention_CPP
1304            and then Is_CPP_Class (Root_Type (Etype (P)))
1305          then
1306             Error_Attr_P
1307               ("invalid use of % attribute with 'C'P'P tagged type");
1308          end if;
1309       end Check_Not_CPP_Type;
1310
1311       -------------------------------
1312       -- Check_Not_Incomplete_Type --
1313       -------------------------------
1314
1315       procedure Check_Not_Incomplete_Type is
1316          E   : Entity_Id;
1317          Typ : Entity_Id;
1318
1319       begin
1320          --  Ada 2005 (AI-50217, AI-326): If the prefix is an explicit
1321          --  dereference we have to check wrong uses of incomplete types
1322          --  (other wrong uses are checked at their freezing point).
1323
1324          --  Example 1: Limited-with
1325
1326          --    limited with Pkg;
1327          --    package P is
1328          --       type Acc is access Pkg.T;
1329          --       X : Acc;
1330          --       S : Integer := X.all'Size;                    -- ERROR
1331          --    end P;
1332
1333          --  Example 2: Tagged incomplete
1334
1335          --     type T is tagged;
1336          --     type Acc is access all T;
1337          --     X : Acc;
1338          --     S : constant Integer := X.all'Size;             -- ERROR
1339          --     procedure Q (Obj : Integer := X.all'Alignment); -- ERROR
1340
1341          if Ada_Version >= Ada_05
1342            and then Nkind (P) = N_Explicit_Dereference
1343          then
1344             E := P;
1345             while Nkind (E) = N_Explicit_Dereference loop
1346                E := Prefix (E);
1347             end loop;
1348
1349             Typ := Etype (E);
1350
1351             if From_With_Type (Typ) then
1352                Error_Attr_P
1353                  ("prefix of % attribute cannot be an incomplete type");
1354
1355             else
1356                if Is_Access_Type (Typ) then
1357                   Typ := Directly_Designated_Type (Typ);
1358                end if;
1359
1360                if Is_Class_Wide_Type (Typ) then
1361                   Typ := Root_Type (Typ);
1362                end if;
1363
1364                --  A legal use of a shadow entity occurs only when the unit
1365                --  where the non-limited view resides is imported via a regular
1366                --  with clause in the current body. Such references to shadow
1367                --  entities may occur in subprogram formals.
1368
1369                if Is_Incomplete_Type (Typ)
1370                  and then From_With_Type (Typ)
1371                  and then Present (Non_Limited_View (Typ))
1372                  and then Is_Legal_Shadow_Entity_In_Body (Typ)
1373                then
1374                   Typ := Non_Limited_View (Typ);
1375                end if;
1376
1377                if Ekind (Typ) = E_Incomplete_Type
1378                  and then No (Full_View (Typ))
1379                then
1380                   Error_Attr_P
1381                     ("prefix of % attribute cannot be an incomplete type");
1382                end if;
1383             end if;
1384          end if;
1385
1386          if not Is_Entity_Name (P)
1387            or else not Is_Type (Entity (P))
1388            or else In_Spec_Expression
1389          then
1390             return;
1391          else
1392             Check_Fully_Declared (P_Type, P);
1393          end if;
1394       end Check_Not_Incomplete_Type;
1395
1396       ----------------------------
1397       -- Check_Object_Reference --
1398       ----------------------------
1399
1400       procedure Check_Object_Reference (P : Node_Id) is
1401          Rtyp : Entity_Id;
1402
1403       begin
1404          --  If we need an object, and we have a prefix that is the name of
1405          --  a function entity, convert it into a function call.
1406
1407          if Is_Entity_Name (P)
1408            and then Ekind (Entity (P)) = E_Function
1409          then
1410             Rtyp := Etype (Entity (P));
1411
1412             Rewrite (P,
1413               Make_Function_Call (Sloc (P),
1414                 Name => Relocate_Node (P)));
1415
1416             Analyze_And_Resolve (P, Rtyp);
1417
1418          --  Otherwise we must have an object reference
1419
1420          elsif not Is_Object_Reference (P) then
1421             Error_Attr_P ("prefix of % attribute must be object");
1422          end if;
1423       end Check_Object_Reference;
1424
1425       ----------------------------
1426       -- Check_PolyORB_Attribute --
1427       ----------------------------
1428
1429       procedure Check_PolyORB_Attribute is
1430       begin
1431          Validate_Non_Static_Attribute_Function_Call;
1432
1433          Check_Type;
1434          Check_Not_CPP_Type;
1435
1436          if Get_PCS_Name /= Name_PolyORB_DSA then
1437             Error_Attr
1438               ("attribute% requires the 'Poly'O'R'B 'P'C'S", N);
1439          end if;
1440       end Check_PolyORB_Attribute;
1441
1442       ------------------------
1443       -- Check_Program_Unit --
1444       ------------------------
1445
1446       procedure Check_Program_Unit is
1447       begin
1448          if Is_Entity_Name (P) then
1449             declare
1450                K : constant Entity_Kind := Ekind (Entity (P));
1451                T : constant Entity_Id   := Etype (Entity (P));
1452
1453             begin
1454                if K in Subprogram_Kind
1455                  or else K in Task_Kind
1456                  or else K in Protected_Kind
1457                  or else K = E_Package
1458                  or else K in Generic_Unit_Kind
1459                  or else (K = E_Variable
1460                             and then
1461                               (Is_Task_Type (T)
1462                                  or else
1463                                Is_Protected_Type (T)))
1464                then
1465                   return;
1466                end if;
1467             end;
1468          end if;
1469
1470          Error_Attr_P ("prefix of % attribute must be program unit");
1471       end Check_Program_Unit;
1472
1473       ---------------------
1474       -- Check_Real_Type --
1475       ---------------------
1476
1477       procedure Check_Real_Type is
1478       begin
1479          Check_Type;
1480
1481          if not Is_Real_Type (P_Type) then
1482             Error_Attr_P ("prefix of % attribute must be real type");
1483          end if;
1484       end Check_Real_Type;
1485
1486       -----------------------
1487       -- Check_Scalar_Type --
1488       -----------------------
1489
1490       procedure Check_Scalar_Type is
1491       begin
1492          Check_Type;
1493
1494          if not Is_Scalar_Type (P_Type) then
1495             Error_Attr_P ("prefix of % attribute must be scalar type");
1496          end if;
1497       end Check_Scalar_Type;
1498
1499       ---------------------------
1500       -- Check_Standard_Prefix --
1501       ---------------------------
1502
1503       procedure Check_Standard_Prefix is
1504       begin
1505          Check_E0;
1506
1507          if Nkind (P) /= N_Identifier
1508            or else Chars (P) /= Name_Standard
1509          then
1510             Error_Attr ("only allowed prefix for % attribute is Standard", P);
1511          end if;
1512       end Check_Standard_Prefix;
1513
1514       ----------------------------
1515       -- Check_Stream_Attribute --
1516       ----------------------------
1517
1518       procedure Check_Stream_Attribute (Nam : TSS_Name_Type) is
1519          Etyp : Entity_Id;
1520          Btyp : Entity_Id;
1521
1522          In_Shared_Var_Procs : Boolean;
1523          --  True when compiling the body of System.Shared_Storage.
1524          --  Shared_Var_Procs. For this runtime package (always compiled in
1525          --  GNAT mode), we allow stream attributes references for limited
1526          --  types for the case where shared passive objects are implemented
1527          --  using stream attributes, which is the default in GNAT's persistent
1528          --  storage implementation.
1529
1530       begin
1531          Validate_Non_Static_Attribute_Function_Call;
1532
1533          --  With the exception of 'Input, Stream attributes are procedures,
1534          --  and can only appear at the position of procedure calls. We check
1535          --  for this here, before they are rewritten, to give a more precise
1536          --  diagnostic.
1537
1538          if Nam = TSS_Stream_Input then
1539             null;
1540
1541          elsif Is_List_Member (N)
1542            and then not Nkind_In (Parent (N), N_Procedure_Call_Statement,
1543                                               N_Aggregate)
1544          then
1545             null;
1546
1547          else
1548             Error_Attr
1549               ("invalid context for attribute%, which is a procedure", N);
1550          end if;
1551
1552          Check_Type;
1553          Btyp := Implementation_Base_Type (P_Type);
1554
1555          --  Stream attributes not allowed on limited types unless the
1556          --  attribute reference was generated by the expander (in which
1557          --  case the underlying type will be used, as described in Sinfo),
1558          --  or the attribute was specified explicitly for the type itself
1559          --  or one of its ancestors (taking visibility rules into account if
1560          --  in Ada 2005 mode), or a pragma Stream_Convert applies to Btyp
1561          --  (with no visibility restriction).
1562
1563          declare
1564             Gen_Body : constant Node_Id := Enclosing_Generic_Body (N);
1565          begin
1566             if Present (Gen_Body) then
1567                In_Shared_Var_Procs :=
1568                  Is_RTE (Corresponding_Spec (Gen_Body), RE_Shared_Var_Procs);
1569             else
1570                In_Shared_Var_Procs := False;
1571             end if;
1572          end;
1573
1574          if (Comes_From_Source (N)
1575               and then not (In_Shared_Var_Procs or In_Instance))
1576            and then not Stream_Attribute_Available (P_Type, Nam)
1577            and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert)
1578          then
1579             Error_Msg_Name_1 := Aname;
1580
1581             if Is_Limited_Type (P_Type) then
1582                Error_Msg_NE
1583                  ("limited type& has no% attribute", P, P_Type);
1584                Explain_Limited_Type (P_Type, P);
1585             else
1586                Error_Msg_NE
1587                  ("attribute% for type& is not available", P, P_Type);
1588             end if;
1589          end if;
1590
1591          --  Check restriction violations
1592
1593          --  First check the No_Streams restriction, which prohibits the use
1594          --  of explicit stream attributes in the source program. We do not
1595          --  prevent the occurrence of stream attributes in generated code,
1596          --  for instance those generated implicitly for dispatching purposes.
1597
1598          if Comes_From_Source (N) then
1599             Check_Restriction (No_Streams, P);
1600          end if;
1601
1602          --  Check special case of Exception_Id and Exception_Occurrence which
1603          --  are not allowed for restriction No_Exception_Regstriation.
1604
1605          if Is_RTE (P_Type, RE_Exception_Id)
1606               or else
1607             Is_RTE (P_Type, RE_Exception_Occurrence)
1608          then
1609             Check_Restriction (No_Exception_Registration, P);
1610          end if;
1611
1612          --  Here we must check that the first argument is an access type
1613          --  that is compatible with Ada.Streams.Root_Stream_Type'Class.
1614
1615          Analyze_And_Resolve (E1);
1616          Etyp := Etype (E1);
1617
1618          --  Note: the double call to Root_Type here is needed because the
1619          --  root type of a class-wide type is the corresponding type (e.g.
1620          --  X for X'Class, and we really want to go to the root.)
1621
1622          if not Is_Access_Type (Etyp)
1623            or else Root_Type (Root_Type (Designated_Type (Etyp))) /=
1624                      RTE (RE_Root_Stream_Type)
1625          then
1626             Error_Attr
1627               ("expected access to Ada.Streams.Root_Stream_Type''Class", E1);
1628          end if;
1629
1630          --  Check that the second argument is of the right type if there is
1631          --  one (the Input attribute has only one argument so this is skipped)
1632
1633          if Present (E2) then
1634             Analyze (E2);
1635
1636             if Nam = TSS_Stream_Read
1637               and then not Is_OK_Variable_For_Out_Formal (E2)
1638             then
1639                Error_Attr
1640                  ("second argument of % attribute must be a variable", E2);
1641             end if;
1642
1643             Resolve (E2, P_Type);
1644          end if;
1645
1646          Check_Not_CPP_Type;
1647       end Check_Stream_Attribute;
1648
1649       -----------------------
1650       -- Check_Task_Prefix --
1651       -----------------------
1652
1653       procedure Check_Task_Prefix is
1654       begin
1655          Analyze (P);
1656
1657          --  Ada 2005 (AI-345): Attribute 'Terminated can be applied to
1658          --  task interface class-wide types.
1659
1660          if Is_Task_Type (Etype (P))
1661            or else (Is_Access_Type (Etype (P))
1662                       and then Is_Task_Type (Designated_Type (Etype (P))))
1663            or else (Ada_Version >= Ada_05
1664                       and then Ekind (Etype (P)) = E_Class_Wide_Type
1665                       and then Is_Interface (Etype (P))
1666                       and then Is_Task_Interface (Etype (P)))
1667          then
1668             Resolve (P);
1669
1670          else
1671             if Ada_Version >= Ada_05 then
1672                Error_Attr_P
1673                  ("prefix of % attribute must be a task or a task " &
1674                   "interface class-wide object");
1675
1676             else
1677                Error_Attr_P ("prefix of % attribute must be a task");
1678             end if;
1679          end if;
1680       end Check_Task_Prefix;
1681
1682       ----------------
1683       -- Check_Type --
1684       ----------------
1685
1686       --  The possibilities are an entity name denoting a type, or an
1687       --  attribute reference that denotes a type (Base or Class). If
1688       --  the type is incomplete, replace it with its full view.
1689
1690       procedure Check_Type is
1691       begin
1692          if not Is_Entity_Name (P)
1693            or else not Is_Type (Entity (P))
1694          then
1695             Error_Attr_P ("prefix of % attribute must be a type");
1696
1697          elsif Is_Protected_Self_Reference (P) then
1698             Error_Attr_P
1699               ("prefix of % attribute denotes current instance "
1700                & "(RM 9.4(21/2))");
1701
1702          elsif Ekind (Entity (P)) = E_Incomplete_Type
1703             and then Present (Full_View (Entity (P)))
1704          then
1705             P_Type := Full_View (Entity (P));
1706             Set_Entity (P, P_Type);
1707          end if;
1708       end Check_Type;
1709
1710       ---------------------
1711       -- Check_Unit_Name --
1712       ---------------------
1713
1714       procedure Check_Unit_Name (Nod : Node_Id) is
1715       begin
1716          if Nkind (Nod) = N_Identifier then
1717             return;
1718
1719          elsif Nkind (Nod) = N_Selected_Component then
1720             Check_Unit_Name (Prefix (Nod));
1721
1722             if Nkind (Selector_Name (Nod)) = N_Identifier then
1723                return;
1724             end if;
1725          end if;
1726
1727          Error_Attr ("argument for % attribute must be unit name", P);
1728       end Check_Unit_Name;
1729
1730       ----------------
1731       -- Error_Attr --
1732       ----------------
1733
1734       procedure Error_Attr is
1735       begin
1736          Set_Etype (N, Any_Type);
1737          Set_Entity (N, Any_Type);
1738          raise Bad_Attribute;
1739       end Error_Attr;
1740
1741       procedure Error_Attr (Msg : String; Error_Node : Node_Id) is
1742       begin
1743          Error_Msg_Name_1 := Aname;
1744          Error_Msg_N (Msg, Error_Node);
1745          Error_Attr;
1746       end Error_Attr;
1747
1748       ------------------
1749       -- Error_Attr_P --
1750       ------------------
1751
1752       procedure Error_Attr_P (Msg : String) is
1753       begin
1754          Error_Msg_Name_1 := Aname;
1755          Error_Msg_F (Msg, P);
1756          Error_Attr;
1757       end Error_Attr_P;
1758
1759       ----------------------------
1760       -- Legal_Formal_Attribute --
1761       ----------------------------
1762
1763       procedure Legal_Formal_Attribute is
1764       begin
1765          Check_E0;
1766
1767          if not Is_Entity_Name (P)
1768            or else not Is_Type (Entity (P))
1769          then
1770             Error_Attr_P ("prefix of % attribute must be generic type");
1771
1772          elsif Is_Generic_Actual_Type (Entity (P))
1773            or else In_Instance
1774            or else In_Inlined_Body
1775          then
1776             null;
1777
1778          elsif Is_Generic_Type (Entity (P)) then
1779             if not Is_Indefinite_Subtype (Entity (P)) then
1780                Error_Attr_P
1781                  ("prefix of % attribute must be indefinite generic type");
1782             end if;
1783
1784          else
1785             Error_Attr_P
1786               ("prefix of % attribute must be indefinite generic type");
1787          end if;
1788
1789          Set_Etype (N, Standard_Boolean);
1790       end Legal_Formal_Attribute;
1791
1792       ------------------------
1793       -- Standard_Attribute --
1794       ------------------------
1795
1796       procedure Standard_Attribute (Val : Int) is
1797       begin
1798          Check_Standard_Prefix;
1799          Rewrite (N, Make_Integer_Literal (Loc, Val));
1800          Analyze (N);
1801       end Standard_Attribute;
1802
1803       -------------------------
1804       -- Unexpected Argument --
1805       -------------------------
1806
1807       procedure Unexpected_Argument (En : Node_Id) is
1808       begin
1809          Error_Attr ("unexpected argument for % attribute", En);
1810       end Unexpected_Argument;
1811
1812       -------------------------------------------------
1813       -- Validate_Non_Static_Attribute_Function_Call --
1814       -------------------------------------------------
1815
1816       --  This function should be moved to Sem_Dist ???
1817
1818       procedure Validate_Non_Static_Attribute_Function_Call is
1819       begin
1820          if In_Preelaborated_Unit
1821            and then not In_Subprogram_Or_Concurrent_Unit
1822          then
1823             Flag_Non_Static_Expr
1824               ("non-static function call in preelaborated unit!", N);
1825          end if;
1826       end Validate_Non_Static_Attribute_Function_Call;
1827
1828    -----------------------------------------------
1829    -- Start of Processing for Analyze_Attribute --
1830    -----------------------------------------------
1831
1832    begin
1833       --  Immediate return if unrecognized attribute (already diagnosed
1834       --  by parser, so there is nothing more that we need to do)
1835
1836       if not Is_Attribute_Name (Aname) then
1837          raise Bad_Attribute;
1838       end if;
1839
1840       --  Deal with Ada 83 issues
1841
1842       if Comes_From_Source (N) then
1843          if not Attribute_83 (Attr_Id) then
1844             if Ada_Version = Ada_83 and then Comes_From_Source (N) then
1845                Error_Msg_Name_1 := Aname;
1846                Error_Msg_N ("(Ada 83) attribute% is not standard?", N);
1847             end if;
1848
1849             if Attribute_Impl_Def (Attr_Id) then
1850                Check_Restriction (No_Implementation_Attributes, N);
1851             end if;
1852          end if;
1853       end if;
1854
1855       --  Deal with Ada 2005 issues
1856
1857       if Attribute_05 (Attr_Id) and then Ada_Version <= Ada_95 then
1858          Check_Restriction (No_Implementation_Attributes, N);
1859       end if;
1860
1861       --   Remote access to subprogram type access attribute reference needs
1862       --   unanalyzed copy for tree transformation. The analyzed copy is used
1863       --   for its semantic information (whether prefix is a remote subprogram
1864       --   name), the unanalyzed copy is used to construct new subtree rooted
1865       --   with N_Aggregate which represents a fat pointer aggregate.
1866
1867       if Aname = Name_Access then
1868          Discard_Node (Copy_Separate_Tree (N));
1869       end if;
1870
1871       --  Analyze prefix and exit if error in analysis. If the prefix is an
1872       --  incomplete type, use full view if available. Note that there are
1873       --  some attributes for which we do not analyze the prefix, since the
1874       --  prefix is not a normal name.
1875
1876       if Aname /= Name_Elab_Body
1877            and then
1878          Aname /= Name_Elab_Spec
1879            and then
1880          Aname /= Name_UET_Address
1881            and then
1882          Aname /= Name_Enabled
1883       then
1884          Analyze (P);
1885          P_Type := Etype (P);
1886
1887          if Is_Entity_Name (P)
1888            and then Present (Entity (P))
1889            and then Is_Type (Entity (P))
1890          then
1891             if Ekind (Entity (P)) = E_Incomplete_Type then
1892                P_Type := Get_Full_View (P_Type);
1893                Set_Entity (P, P_Type);
1894                Set_Etype  (P, P_Type);
1895
1896             elsif Entity (P) = Current_Scope
1897               and then Is_Record_Type (Entity (P))
1898             then
1899                --  Use of current instance within the type. Verify that if the
1900                --  attribute appears within a constraint, it  yields an access
1901                --  type, other uses are illegal.
1902
1903                declare
1904                   Par : Node_Id;
1905
1906                begin
1907                   Par := Parent (N);
1908                   while Present (Par)
1909                     and then Nkind (Parent (Par)) /= N_Component_Definition
1910                   loop
1911                      Par := Parent (Par);
1912                   end loop;
1913
1914                   if Present (Par)
1915                     and then Nkind (Par) = N_Subtype_Indication
1916                   then
1917                      if Attr_Id /= Attribute_Access
1918                        and then Attr_Id /= Attribute_Unchecked_Access
1919                        and then Attr_Id /= Attribute_Unrestricted_Access
1920                      then
1921                         Error_Msg_N
1922                           ("in a constraint the current instance can only"
1923                              & " be used with an access attribute", N);
1924                      end if;
1925                   end if;
1926                end;
1927             end if;
1928          end if;
1929
1930          if P_Type = Any_Type then
1931             raise Bad_Attribute;
1932          end if;
1933
1934          P_Base_Type := Base_Type (P_Type);
1935       end if;
1936
1937       --  Analyze expressions that may be present, exiting if an error occurs
1938
1939       if No (Exprs) then
1940          E1 := Empty;
1941          E2 := Empty;
1942
1943       else
1944          E1 := First (Exprs);
1945          Analyze (E1);
1946
1947          --  Check for missing/bad expression (result of previous error)
1948
1949          if No (E1) or else Etype (E1) = Any_Type then
1950             raise Bad_Attribute;
1951          end if;
1952
1953          E2 := Next (E1);
1954
1955          if Present (E2) then
1956             Analyze (E2);
1957
1958             if Etype (E2) = Any_Type then
1959                raise Bad_Attribute;
1960             end if;
1961
1962             if Present (Next (E2)) then
1963                Unexpected_Argument (Next (E2));
1964             end if;
1965          end if;
1966       end if;
1967
1968       --  Ada 2005 (AI-345): Ensure that the compiler gives exactly the current
1969       --  output compiling in Ada 95 mode for the case of ambiguous prefixes.
1970
1971       if Ada_Version < Ada_05
1972         and then Is_Overloaded (P)
1973         and then Aname /= Name_Access
1974         and then Aname /= Name_Address
1975         and then Aname /= Name_Code_Address
1976         and then Aname /= Name_Count
1977         and then Aname /= Name_Result
1978         and then Aname /= Name_Unchecked_Access
1979       then
1980          Error_Attr ("ambiguous prefix for % attribute", P);
1981
1982       elsif Ada_Version >= Ada_05
1983         and then Is_Overloaded (P)
1984         and then Aname /= Name_Access
1985         and then Aname /= Name_Address
1986         and then Aname /= Name_Code_Address
1987         and then Aname /= Name_Result
1988         and then Aname /= Name_Unchecked_Access
1989       then
1990          --  Ada 2005 (AI-345): Since protected and task types have primitive
1991          --  entry wrappers, the attributes Count, Caller and AST_Entry require
1992          --  a context check
1993
1994          if Ada_Version >= Ada_05
1995            and then (Aname = Name_Count
1996                       or else Aname = Name_Caller
1997                       or else Aname = Name_AST_Entry)
1998          then
1999             declare
2000                Count : Natural := 0;
2001                I     : Interp_Index;
2002                It    : Interp;
2003
2004             begin
2005                Get_First_Interp (P, I, It);
2006                while Present (It.Nam) loop
2007                   if Comes_From_Source (It.Nam) then
2008                      Count := Count + 1;
2009                   else
2010                      Remove_Interp (I);
2011                   end if;
2012
2013                   Get_Next_Interp (I, It);
2014                end loop;
2015
2016                if Count > 1 then
2017                   Error_Attr ("ambiguous prefix for % attribute", P);
2018                else
2019                   Set_Is_Overloaded (P, False);
2020                end if;
2021             end;
2022
2023          else
2024             Error_Attr ("ambiguous prefix for % attribute", P);
2025          end if;
2026       end if;
2027
2028       --  Remaining processing depends on attribute
2029
2030       case Attr_Id is
2031
2032       ------------------
2033       -- Abort_Signal --
2034       ------------------
2035
2036       when Attribute_Abort_Signal =>
2037          Check_Standard_Prefix;
2038          Rewrite (N,
2039            New_Reference_To (Stand.Abort_Signal, Loc));
2040          Analyze (N);
2041
2042       ------------
2043       -- Access --
2044       ------------
2045
2046       when Attribute_Access =>
2047          Analyze_Access_Attribute;
2048
2049       -------------
2050       -- Address --
2051       -------------
2052
2053       when Attribute_Address =>
2054          Check_E0;
2055
2056          --  Check for some junk cases, where we have to allow the address
2057          --  attribute but it does not make much sense, so at least for now
2058          --  just replace with Null_Address.
2059
2060          --  We also do this if the prefix is a reference to the AST_Entry
2061          --  attribute. If expansion is active, the attribute will be
2062          --  replaced by a function call, and address will work fine and
2063          --  get the proper value, but if expansion is not active, then
2064          --  the check here allows proper semantic analysis of the reference.
2065
2066          --  An Address attribute created by expansion is legal even when it
2067          --  applies to other entity-denoting expressions.
2068
2069          if Is_Protected_Self_Reference (P) then
2070
2071             --  Address attribute on a protected object self reference is legal
2072
2073             null;
2074
2075          elsif Is_Entity_Name (P) then
2076             declare
2077                Ent : constant Entity_Id := Entity (P);
2078
2079             begin
2080                if Is_Subprogram (Ent) then
2081                   Set_Address_Taken (Ent);
2082                   Kill_Current_Values (Ent);
2083
2084                   --  An Address attribute is accepted when generated by the
2085                   --  compiler for dispatching operation, and an error is
2086                   --  issued once the subprogram is frozen (to avoid confusing
2087                   --  errors about implicit uses of Address in the dispatch
2088                   --  table initialization).
2089
2090                   if Has_Pragma_Inline_Always (Entity (P))
2091                     and then Comes_From_Source (P)
2092                   then
2093                      Error_Attr_P
2094                        ("prefix of % attribute cannot be Inline_Always" &
2095                         " subprogram");
2096
2097                   --  It is illegal to apply 'Address to an intrinsic
2098                   --  subprogram. This is now formalized in AI05-0095.
2099                   --  In an instance, an attempt to obtain 'Address of an
2100                   --  intrinsic subprogram (e.g the renaming of a predefined
2101                   --  operator that is an actual) raises Program_Error.
2102
2103                   elsif Convention (Ent) = Convention_Intrinsic then
2104                      if In_Instance then
2105                         Rewrite (N,
2106                           Make_Raise_Program_Error (Loc,
2107                             Reason => PE_Address_Of_Intrinsic));
2108
2109                      else
2110                         Error_Msg_N
2111                          ("cannot take Address of intrinsic subprogram", N);
2112                      end if;
2113
2114                   --  Issue an error if prefix denotes an eliminated subprogram
2115
2116                   else
2117                      Check_For_Eliminated_Subprogram (P, Ent);
2118                   end if;
2119
2120                elsif Is_Object (Ent)
2121                  or else Ekind (Ent) = E_Label
2122                then
2123                   Set_Address_Taken (Ent);
2124
2125                --  If we have an address of an object, and the attribute
2126                --  comes from source, then set the object as potentially
2127                --  source modified. We do this because the resulting address
2128                --  can potentially be used to modify the variable and we
2129                --  might not detect this, leading to some junk warnings.
2130
2131                   Set_Never_Set_In_Source (Ent, False);
2132
2133                elsif (Is_Concurrent_Type (Etype (Ent))
2134                        and then Etype (Ent) = Base_Type (Ent))
2135                  or else Ekind (Ent) = E_Package
2136                  or else Is_Generic_Unit (Ent)
2137                then
2138                   Rewrite (N,
2139                     New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
2140
2141                else
2142                   Error_Attr ("invalid prefix for % attribute", P);
2143                end if;
2144             end;
2145
2146          elsif Nkind (P) = N_Attribute_Reference
2147            and then Attribute_Name (P) = Name_AST_Entry
2148          then
2149             Rewrite (N,
2150               New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
2151
2152          elsif Is_Object_Reference (P) then
2153             null;
2154
2155          elsif Nkind (P) = N_Selected_Component
2156            and then Is_Subprogram (Entity (Selector_Name (P)))
2157          then
2158             null;
2159
2160          --  What exactly are we allowing here ??? and is this properly
2161          --  documented in the sinfo documentation for this node ???
2162
2163          elsif not Comes_From_Source (N) then
2164             null;
2165
2166          else
2167             Error_Attr ("invalid prefix for % attribute", P);
2168          end if;
2169
2170          Set_Etype (N, RTE (RE_Address));
2171
2172       ------------------
2173       -- Address_Size --
2174       ------------------
2175
2176       when Attribute_Address_Size =>
2177          Standard_Attribute (System_Address_Size);
2178
2179       --------------
2180       -- Adjacent --
2181       --------------
2182
2183       when Attribute_Adjacent =>
2184          Check_Floating_Point_Type_2;
2185          Set_Etype (N, P_Base_Type);
2186          Resolve (E1, P_Base_Type);
2187          Resolve (E2, P_Base_Type);
2188
2189       ---------
2190       -- Aft --
2191       ---------
2192
2193       when Attribute_Aft =>
2194          Check_Fixed_Point_Type_0;
2195          Set_Etype (N, Universal_Integer);
2196
2197       ---------------
2198       -- Alignment --
2199       ---------------
2200
2201       when Attribute_Alignment =>
2202
2203          --  Don't we need more checking here, cf Size ???
2204
2205          Check_E0;
2206          Check_Not_Incomplete_Type;
2207          Check_Not_CPP_Type;
2208          Set_Etype (N, Universal_Integer);
2209
2210       ---------------
2211       -- Asm_Input --
2212       ---------------
2213
2214       when Attribute_Asm_Input =>
2215          Check_Asm_Attribute;
2216          Set_Etype (N, RTE (RE_Asm_Input_Operand));
2217
2218       ----------------
2219       -- Asm_Output --
2220       ----------------
2221
2222       when Attribute_Asm_Output =>
2223          Check_Asm_Attribute;
2224
2225          if Etype (E2) = Any_Type then
2226             return;
2227
2228          elsif Aname = Name_Asm_Output then
2229             if not Is_Variable (E2) then
2230                Error_Attr
2231                  ("second argument for Asm_Output is not variable", E2);
2232             end if;
2233          end if;
2234
2235          Note_Possible_Modification (E2, Sure => True);
2236          Set_Etype (N, RTE (RE_Asm_Output_Operand));
2237
2238       ---------------
2239       -- AST_Entry --
2240       ---------------
2241
2242       when Attribute_AST_Entry => AST_Entry : declare
2243          Ent  : Entity_Id;
2244          Pref : Node_Id;
2245          Ptyp : Entity_Id;
2246
2247          Indexed : Boolean;
2248          --  Indicates if entry family index is present. Note the coding
2249          --  here handles the entry family case, but in fact it cannot be
2250          --  executed currently, because pragma AST_Entry does not permit
2251          --  the specification of an entry family.
2252
2253          procedure Bad_AST_Entry;
2254          --  Signal a bad AST_Entry pragma
2255
2256          function OK_Entry (E : Entity_Id) return Boolean;
2257          --  Checks that E is of an appropriate entity kind for an entry
2258          --  (i.e. E_Entry if Index is False, or E_Entry_Family if Index
2259          --  is set True for the entry family case). In the True case,
2260          --  makes sure that Is_AST_Entry is set on the entry.
2261
2262          -------------------
2263          -- Bad_AST_Entry --
2264          -------------------
2265
2266          procedure Bad_AST_Entry is
2267          begin
2268             Error_Attr_P ("prefix for % attribute must be task entry");
2269          end Bad_AST_Entry;
2270
2271          --------------
2272          -- OK_Entry --
2273          --------------
2274
2275          function OK_Entry (E : Entity_Id) return Boolean is
2276             Result : Boolean;
2277
2278          begin
2279             if Indexed then
2280                Result := (Ekind (E) = E_Entry_Family);
2281             else
2282                Result := (Ekind (E) = E_Entry);
2283             end if;
2284
2285             if Result then
2286                if not Is_AST_Entry (E) then
2287                   Error_Msg_Name_2 := Aname;
2288                   Error_Attr ("% attribute requires previous % pragma", P);
2289                end if;
2290             end if;
2291
2292             return Result;
2293          end OK_Entry;
2294
2295       --  Start of processing for AST_Entry
2296
2297       begin
2298          Check_VMS (N);
2299          Check_E0;
2300
2301          --  Deal with entry family case
2302
2303          if Nkind (P) = N_Indexed_Component then
2304             Pref := Prefix (P);
2305             Indexed := True;
2306          else
2307             Pref := P;
2308             Indexed := False;
2309          end if;
2310
2311          Ptyp := Etype (Pref);
2312
2313          if Ptyp = Any_Type or else Error_Posted (Pref) then
2314             return;
2315          end if;
2316
2317          --  If the prefix is a selected component whose prefix is of an
2318          --  access type, then introduce an explicit dereference.
2319          --  ??? Could we reuse Check_Dereference here?
2320
2321          if Nkind (Pref) = N_Selected_Component
2322            and then Is_Access_Type (Ptyp)
2323          then
2324             Rewrite (Pref,
2325               Make_Explicit_Dereference (Sloc (Pref),
2326                 Relocate_Node (Pref)));
2327             Analyze_And_Resolve (Pref, Designated_Type (Ptyp));
2328          end if;
2329
2330          --  Prefix can be of the form a.b, where a is a task object
2331          --  and b is one of the entries of the corresponding task type.
2332
2333          if Nkind (Pref) = N_Selected_Component
2334            and then OK_Entry (Entity (Selector_Name (Pref)))
2335            and then Is_Object_Reference (Prefix (Pref))
2336            and then Is_Task_Type (Etype (Prefix (Pref)))
2337          then
2338             null;
2339
2340          --  Otherwise the prefix must be an entry of a containing task,
2341          --  or of a variable of the enclosing task type.
2342
2343          else
2344             if Nkind_In (Pref, N_Identifier, N_Expanded_Name) then
2345                Ent := Entity (Pref);
2346
2347                if not OK_Entry (Ent)
2348                  or else not In_Open_Scopes (Scope (Ent))
2349                then
2350                   Bad_AST_Entry;
2351                end if;
2352
2353             else
2354                Bad_AST_Entry;
2355             end if;
2356          end if;
2357
2358          Set_Etype (N, RTE (RE_AST_Handler));
2359       end AST_Entry;
2360
2361       ----------
2362       -- Base --
2363       ----------
2364
2365       --  Note: when the base attribute appears in the context of a subtype
2366       --  mark, the analysis is done by Sem_Ch8.Find_Type, rather than by
2367       --  the following circuit.
2368
2369       when Attribute_Base => Base : declare
2370          Typ : Entity_Id;
2371
2372       begin
2373          Check_E0;
2374          Find_Type (P);
2375          Typ := Entity (P);
2376
2377          if Ada_Version >= Ada_95
2378            and then not Is_Scalar_Type (Typ)
2379            and then not Is_Generic_Type (Typ)
2380          then
2381             Error_Attr_P ("prefix of Base attribute must be scalar type");
2382
2383          elsif Sloc (Typ) = Standard_Location
2384            and then Base_Type (Typ) = Typ
2385            and then Warn_On_Redundant_Constructs
2386          then
2387                Error_Msg_NE
2388                  ("?redundant attribute, & is its own base type", N, Typ);
2389          end if;
2390
2391          Set_Etype (N, Base_Type (Entity (P)));
2392          Set_Entity (N, Base_Type (Entity (P)));
2393          Rewrite (N, New_Reference_To (Entity (N), Loc));
2394          Analyze (N);
2395       end Base;
2396
2397       ---------
2398       -- Bit --
2399       ---------
2400
2401       when Attribute_Bit => Bit :
2402       begin
2403          Check_E0;
2404
2405          if not Is_Object_Reference (P) then
2406             Error_Attr_P ("prefix for % attribute must be object");
2407
2408          --  What about the access object cases ???
2409
2410          else
2411             null;
2412          end if;
2413
2414          Set_Etype (N, Universal_Integer);
2415       end Bit;
2416
2417       ---------------
2418       -- Bit_Order --
2419       ---------------
2420
2421       when Attribute_Bit_Order => Bit_Order :
2422       begin
2423          Check_E0;
2424          Check_Type;
2425
2426          if not Is_Record_Type (P_Type) then
2427             Error_Attr_P ("prefix of % attribute must be record type");
2428          end if;
2429
2430          if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then
2431             Rewrite (N,
2432               New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
2433          else
2434             Rewrite (N,
2435               New_Occurrence_Of (RTE (RE_Low_Order_First), Loc));
2436          end if;
2437
2438          Set_Etype (N, RTE (RE_Bit_Order));
2439          Resolve (N);
2440
2441          --  Reset incorrect indication of staticness
2442
2443          Set_Is_Static_Expression (N, False);
2444       end Bit_Order;
2445
2446       ------------------
2447       -- Bit_Position --
2448       ------------------
2449
2450       --  Note: in generated code, we can have a Bit_Position attribute
2451       --  applied to a (naked) record component (i.e. the prefix is an
2452       --  identifier that references an E_Component or E_Discriminant
2453       --  entity directly, and this is interpreted as expected by Gigi.
2454       --  The following code will not tolerate such usage, but when the
2455       --  expander creates this special case, it marks it as analyzed
2456       --  immediately and sets an appropriate type.
2457
2458       when Attribute_Bit_Position =>
2459          if Comes_From_Source (N) then
2460             Check_Component;
2461          end if;
2462
2463          Set_Etype (N, Universal_Integer);
2464
2465       ------------------
2466       -- Body_Version --
2467       ------------------
2468
2469       when Attribute_Body_Version =>
2470          Check_E0;
2471          Check_Program_Unit;
2472          Set_Etype (N, RTE (RE_Version_String));
2473
2474       --------------
2475       -- Callable --
2476       --------------
2477
2478       when Attribute_Callable =>
2479          Check_E0;
2480          Set_Etype (N, Standard_Boolean);
2481          Check_Task_Prefix;
2482
2483       ------------
2484       -- Caller --
2485       ------------
2486
2487       when Attribute_Caller => Caller : declare
2488          Ent        : Entity_Id;
2489          S          : Entity_Id;
2490
2491       begin
2492          Check_E0;
2493
2494          if Nkind_In (P, N_Identifier, N_Expanded_Name) then
2495             Ent := Entity (P);
2496
2497             if not Is_Entry (Ent) then
2498                Error_Attr ("invalid entry name", N);
2499             end if;
2500
2501          else
2502             Error_Attr ("invalid entry name", N);
2503             return;
2504          end if;
2505
2506          for J in reverse 0 .. Scope_Stack.Last loop
2507             S := Scope_Stack.Table (J).Entity;
2508
2509             if S = Scope (Ent) then
2510                Error_Attr ("Caller must appear in matching accept or body", N);
2511             elsif S = Ent then
2512                exit;
2513             end if;
2514          end loop;
2515
2516          Set_Etype (N, RTE (RO_AT_Task_Id));
2517       end Caller;
2518
2519       -------------
2520       -- Ceiling --
2521       -------------
2522
2523       when Attribute_Ceiling =>
2524          Check_Floating_Point_Type_1;
2525          Set_Etype (N, P_Base_Type);
2526          Resolve (E1, P_Base_Type);
2527
2528       -----------
2529       -- Class --
2530       -----------
2531
2532       when Attribute_Class =>
2533          Check_Restriction (No_Dispatch, N);
2534          Check_E0;
2535          Find_Type (N);
2536
2537       ------------------
2538       -- Code_Address --
2539       ------------------
2540
2541       when Attribute_Code_Address =>
2542          Check_E0;
2543
2544          if Nkind (P) = N_Attribute_Reference
2545            and then (Attribute_Name (P) = Name_Elab_Body
2546                        or else
2547                      Attribute_Name (P) = Name_Elab_Spec)
2548          then
2549             null;
2550
2551          elsif not Is_Entity_Name (P)
2552            or else (Ekind (Entity (P)) /= E_Function
2553                       and then
2554                     Ekind (Entity (P)) /= E_Procedure)
2555          then
2556             Error_Attr ("invalid prefix for % attribute", P);
2557             Set_Address_Taken (Entity (P));
2558
2559          --  Issue an error if the prefix denotes an eliminated subprogram
2560
2561          else
2562             Check_For_Eliminated_Subprogram (P, Entity (P));
2563          end if;
2564
2565          Set_Etype (N, RTE (RE_Address));
2566
2567       ----------------------
2568       -- Compiler_Version --
2569       ----------------------
2570
2571       when Attribute_Compiler_Version =>
2572          Check_E0;
2573          Check_Standard_Prefix;
2574          Rewrite (N, Make_String_Literal (Loc, "GNAT " & Gnat_Version_String));
2575          Analyze_And_Resolve (N, Standard_String);
2576
2577       --------------------
2578       -- Component_Size --
2579       --------------------
2580
2581       when Attribute_Component_Size =>
2582          Check_E0;
2583          Set_Etype (N, Universal_Integer);
2584
2585          --  Note: unlike other array attributes, unconstrained arrays are OK
2586
2587          if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then
2588             null;
2589          else
2590             Check_Array_Type;
2591          end if;
2592
2593       -------------
2594       -- Compose --
2595       -------------
2596
2597       when Attribute_Compose =>
2598          Check_Floating_Point_Type_2;
2599          Set_Etype (N, P_Base_Type);
2600          Resolve (E1, P_Base_Type);
2601          Resolve (E2, Any_Integer);
2602
2603       -----------------
2604       -- Constrained --
2605       -----------------
2606
2607       when Attribute_Constrained =>
2608          Check_E0;
2609          Set_Etype (N, Standard_Boolean);
2610
2611          --  Case from RM J.4(2) of constrained applied to private type
2612
2613          if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
2614             Check_Restriction (No_Obsolescent_Features, N);
2615
2616             if Warn_On_Obsolescent_Feature then
2617                Error_Msg_N
2618                  ("constrained for private type is an " &
2619                   "obsolescent feature (RM J.4)?", N);
2620             end if;
2621
2622             --  If we are within an instance, the attribute must be legal
2623             --  because it was valid in the generic unit. Ditto if this is
2624             --  an inlining of a function declared in an instance.
2625
2626             if In_Instance
2627               or else In_Inlined_Body
2628             then
2629                return;
2630
2631             --  For sure OK if we have a real private type itself, but must
2632             --  be completed, cannot apply Constrained to incomplete type.
2633
2634             elsif Is_Private_Type (Entity (P)) then
2635
2636                --  Note: this is one of the Annex J features that does not
2637                --  generate a warning from -gnatwj, since in fact it seems
2638                --  very useful, and is used in the GNAT runtime.
2639
2640                Check_Not_Incomplete_Type;
2641                return;
2642             end if;
2643
2644          --  Normal (non-obsolescent case) of application to object of
2645          --  a discriminated type.
2646
2647          else
2648             Check_Object_Reference (P);
2649
2650             --  If N does not come from source, then we allow the
2651             --  the attribute prefix to be of a private type whose
2652             --  full type has discriminants. This occurs in cases
2653             --  involving expanded calls to stream attributes.
2654
2655             if not Comes_From_Source (N) then
2656                P_Type := Underlying_Type (P_Type);
2657             end if;
2658
2659             --  Must have discriminants or be an access type designating
2660             --  a type with discriminants. If it is a classwide type is ???
2661             --  has unknown discriminants.
2662
2663             if Has_Discriminants (P_Type)
2664                or else Has_Unknown_Discriminants (P_Type)
2665                or else
2666                  (Is_Access_Type (P_Type)
2667                    and then Has_Discriminants (Designated_Type (P_Type)))
2668             then
2669                return;
2670
2671             --  Also allow an object of a generic type if extensions allowed
2672             --  and allow this for any type at all.
2673
2674             elsif (Is_Generic_Type (P_Type)
2675                      or else Is_Generic_Actual_Type (P_Type))
2676               and then Extensions_Allowed
2677             then
2678                return;
2679             end if;
2680          end if;
2681
2682          --  Fall through if bad prefix
2683
2684          Error_Attr_P
2685            ("prefix of % attribute must be object of discriminated type");
2686
2687       ---------------
2688       -- Copy_Sign --
2689       ---------------
2690
2691       when Attribute_Copy_Sign =>
2692          Check_Floating_Point_Type_2;
2693          Set_Etype (N, P_Base_Type);
2694          Resolve (E1, P_Base_Type);
2695          Resolve (E2, P_Base_Type);
2696
2697       -----------
2698       -- Count --
2699       -----------
2700
2701       when Attribute_Count => Count :
2702       declare
2703          Ent : Entity_Id;
2704          S   : Entity_Id;
2705          Tsk : Entity_Id;
2706
2707       begin
2708          Check_E0;
2709
2710          if Nkind_In (P, N_Identifier, N_Expanded_Name) then
2711             Ent := Entity (P);
2712
2713             if Ekind (Ent) /= E_Entry then
2714                Error_Attr ("invalid entry name", N);
2715             end if;
2716
2717          elsif Nkind (P) = N_Indexed_Component then
2718             if not Is_Entity_Name (Prefix (P))
2719               or else  No (Entity (Prefix (P)))
2720               or else Ekind (Entity (Prefix (P))) /= E_Entry_Family
2721             then
2722                if Nkind (Prefix (P)) = N_Selected_Component
2723                  and then Present (Entity (Selector_Name (Prefix (P))))
2724                  and then Ekind (Entity (Selector_Name (Prefix (P)))) =
2725                                                              E_Entry_Family
2726                then
2727                   Error_Attr
2728                     ("attribute % must apply to entry of current task", P);
2729
2730                else
2731                   Error_Attr ("invalid entry family name", P);
2732                end if;
2733                return;
2734
2735             else
2736                Ent := Entity (Prefix (P));
2737             end if;
2738
2739          elsif Nkind (P) = N_Selected_Component
2740            and then Present (Entity (Selector_Name (P)))
2741            and then Ekind (Entity (Selector_Name (P))) = E_Entry
2742          then
2743             Error_Attr
2744               ("attribute % must apply to entry of current task", P);
2745
2746          else
2747             Error_Attr ("invalid entry name", N);
2748             return;
2749          end if;
2750
2751          for J in reverse 0 .. Scope_Stack.Last loop
2752             S := Scope_Stack.Table (J).Entity;
2753
2754             if S = Scope (Ent) then
2755                if Nkind (P) = N_Expanded_Name then
2756                   Tsk := Entity (Prefix (P));
2757
2758                   --  The prefix denotes either the task type, or else a
2759                   --  single task whose task type is being analyzed.
2760
2761                   if (Is_Type (Tsk)
2762                       and then Tsk = S)
2763
2764                     or else (not Is_Type (Tsk)
2765                       and then Etype (Tsk) = S
2766                       and then not (Comes_From_Source (S)))
2767                   then
2768                      null;
2769                   else
2770                      Error_Attr
2771                        ("Attribute % must apply to entry of current task", N);
2772                   end if;
2773                end if;
2774
2775                exit;
2776
2777             elsif Ekind (Scope (Ent)) in Task_Kind
2778               and then Ekind (S) /= E_Loop
2779               and then Ekind (S) /= E_Block
2780               and then Ekind (S) /= E_Entry
2781               and then Ekind (S) /= E_Entry_Family
2782             then
2783                Error_Attr ("Attribute % cannot appear in inner unit", N);
2784
2785             elsif Ekind (Scope (Ent)) = E_Protected_Type
2786               and then not Has_Completion (Scope (Ent))
2787             then
2788                Error_Attr ("attribute % can only be used inside body", N);
2789             end if;
2790          end loop;
2791
2792          if Is_Overloaded (P) then
2793             declare
2794                Index : Interp_Index;
2795                It    : Interp;
2796
2797             begin
2798                Get_First_Interp (P, Index, It);
2799
2800                while Present (It.Nam) loop
2801                   if It.Nam = Ent then
2802                      null;
2803
2804                   --  Ada 2005 (AI-345): Do not consider primitive entry
2805                   --  wrappers generated for task or protected types.
2806
2807                   elsif Ada_Version >= Ada_05
2808                     and then not Comes_From_Source (It.Nam)
2809                   then
2810                      null;
2811
2812                   else
2813                      Error_Attr ("ambiguous entry name", N);
2814                   end if;
2815
2816                   Get_Next_Interp (Index, It);
2817                end loop;
2818             end;
2819          end if;
2820
2821          Set_Etype (N, Universal_Integer);
2822       end Count;
2823
2824       -----------------------
2825       -- Default_Bit_Order --
2826       -----------------------
2827
2828       when Attribute_Default_Bit_Order => Default_Bit_Order :
2829       begin
2830          Check_Standard_Prefix;
2831
2832          if Bytes_Big_Endian then
2833             Rewrite (N,
2834               Make_Integer_Literal (Loc, False_Value));
2835          else
2836             Rewrite (N,
2837               Make_Integer_Literal (Loc, True_Value));
2838          end if;
2839
2840          Set_Etype (N, Universal_Integer);
2841          Set_Is_Static_Expression (N);
2842       end Default_Bit_Order;
2843
2844       --------------
2845       -- Definite --
2846       --------------
2847
2848       when Attribute_Definite =>
2849          Legal_Formal_Attribute;
2850
2851       -----------
2852       -- Delta --
2853       -----------
2854
2855       when Attribute_Delta =>
2856          Check_Fixed_Point_Type_0;
2857          Set_Etype (N, Universal_Real);
2858
2859       ------------
2860       -- Denorm --
2861       ------------
2862
2863       when Attribute_Denorm =>
2864          Check_Floating_Point_Type_0;
2865          Set_Etype (N, Standard_Boolean);
2866
2867       ------------
2868       -- Digits --
2869       ------------
2870
2871       when Attribute_Digits =>
2872          Check_E0;
2873          Check_Type;
2874
2875          if not Is_Floating_Point_Type (P_Type)
2876            and then not Is_Decimal_Fixed_Point_Type (P_Type)
2877          then
2878             Error_Attr_P
2879               ("prefix of % attribute must be float or decimal type");
2880          end if;
2881
2882          Set_Etype (N, Universal_Integer);
2883
2884       ---------------
2885       -- Elab_Body --
2886       ---------------
2887
2888       --  Also handles processing for Elab_Spec
2889
2890       when Attribute_Elab_Body | Attribute_Elab_Spec =>
2891          Check_E0;
2892          Check_Unit_Name (P);
2893          Set_Etype (N, Standard_Void_Type);
2894
2895          --  We have to manually call the expander in this case to get
2896          --  the necessary expansion (normally attributes that return
2897          --  entities are not expanded).
2898
2899          Expand (N);
2900
2901       ---------------
2902       -- Elab_Spec --
2903       ---------------
2904
2905       --  Shares processing with Elab_Body
2906
2907       ----------------
2908       -- Elaborated --
2909       ----------------
2910
2911       when Attribute_Elaborated =>
2912          Check_E0;
2913          Check_Library_Unit;
2914          Set_Etype (N, Standard_Boolean);
2915
2916       ----------
2917       -- Emax --
2918       ----------
2919
2920       when Attribute_Emax =>
2921          Check_Floating_Point_Type_0;
2922          Set_Etype (N, Universal_Integer);
2923
2924       -------------
2925       -- Enabled --
2926       -------------
2927
2928       when Attribute_Enabled =>
2929          Check_Either_E0_Or_E1;
2930
2931          if Present (E1) then
2932             if not Is_Entity_Name (E1) or else No (Entity (E1)) then
2933                Error_Msg_N ("entity name expected for Enabled attribute", E1);
2934                E1 := Empty;
2935             end if;
2936          end if;
2937
2938          if Nkind (P) /= N_Identifier then
2939             Error_Msg_N ("identifier expected (check name)", P);
2940          elsif Get_Check_Id (Chars (P)) = No_Check_Id then
2941             Error_Msg_N ("& is not a recognized check name", P);
2942          end if;
2943
2944          Set_Etype (N, Standard_Boolean);
2945
2946       --------------
2947       -- Enum_Rep --
2948       --------------
2949
2950       when Attribute_Enum_Rep => Enum_Rep : declare
2951       begin
2952          if Present (E1) then
2953             Check_E1;
2954             Check_Discrete_Type;
2955             Resolve (E1, P_Base_Type);
2956
2957          else
2958             if not Is_Entity_Name (P)
2959               or else (not Is_Object (Entity (P))
2960                          and then
2961                        Ekind (Entity (P)) /= E_Enumeration_Literal)
2962             then
2963                Error_Attr_P
2964                  ("prefix of %attribute must be " &
2965                   "discrete type/object or enum literal");
2966             end if;
2967          end if;
2968
2969          Set_Etype (N, Universal_Integer);
2970       end Enum_Rep;
2971
2972       --------------
2973       -- Enum_Val --
2974       --------------
2975
2976       when Attribute_Enum_Val => Enum_Val : begin
2977          Check_E1;
2978          Check_Type;
2979
2980          if not Is_Enumeration_Type (P_Type) then
2981             Error_Attr_P ("prefix of % attribute must be enumeration type");
2982          end if;
2983
2984          --  If the enumeration type has a standard representation, the effect
2985          --  is the same as 'Val, so rewrite the attribute as a 'Val.
2986
2987          if not Has_Non_Standard_Rep (P_Base_Type) then
2988             Rewrite (N,
2989               Make_Attribute_Reference (Loc,
2990                 Prefix         => Relocate_Node (Prefix (N)),
2991                 Attribute_Name => Name_Val,
2992                 Expressions    => New_List (Relocate_Node (E1))));
2993             Analyze_And_Resolve (N, P_Base_Type);
2994
2995          --  Non-standard representation case (enumeration with holes)
2996
2997          else
2998             Check_Enum_Image;
2999             Resolve (E1, Any_Integer);
3000             Set_Etype (N, P_Base_Type);
3001          end if;
3002       end Enum_Val;
3003
3004       -------------
3005       -- Epsilon --
3006       -------------
3007
3008       when Attribute_Epsilon =>
3009          Check_Floating_Point_Type_0;
3010          Set_Etype (N, Universal_Real);
3011
3012       --------------
3013       -- Exponent --
3014       --------------
3015
3016       when Attribute_Exponent =>
3017          Check_Floating_Point_Type_1;
3018          Set_Etype (N, Universal_Integer);
3019          Resolve (E1, P_Base_Type);
3020
3021       ------------------
3022       -- External_Tag --
3023       ------------------
3024
3025       when Attribute_External_Tag =>
3026          Check_E0;
3027          Check_Type;
3028
3029          Set_Etype (N, Standard_String);
3030
3031          if not Is_Tagged_Type (P_Type) then
3032             Error_Attr_P ("prefix of % attribute must be tagged");
3033          end if;
3034
3035       ---------------
3036       -- Fast_Math --
3037       ---------------
3038
3039       when Attribute_Fast_Math =>
3040          Check_Standard_Prefix;
3041
3042          if Opt.Fast_Math then
3043             Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
3044          else
3045             Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
3046          end if;
3047
3048       -----------
3049       -- First --
3050       -----------
3051
3052       when Attribute_First =>
3053          Check_Array_Or_Scalar_Type;
3054
3055       ---------------
3056       -- First_Bit --
3057       ---------------
3058
3059       when Attribute_First_Bit =>
3060          Check_Component;
3061          Set_Etype (N, Universal_Integer);
3062
3063       -----------------
3064       -- Fixed_Value --
3065       -----------------
3066
3067       when Attribute_Fixed_Value =>
3068          Check_E1;
3069          Check_Fixed_Point_Type;
3070          Resolve (E1, Any_Integer);
3071          Set_Etype (N, P_Base_Type);
3072
3073       -----------
3074       -- Floor --
3075       -----------
3076
3077       when Attribute_Floor =>
3078          Check_Floating_Point_Type_1;
3079          Set_Etype (N, P_Base_Type);
3080          Resolve (E1, P_Base_Type);
3081
3082       ----------
3083       -- Fore --
3084       ----------
3085
3086       when Attribute_Fore =>
3087          Check_Fixed_Point_Type_0;
3088          Set_Etype (N, Universal_Integer);
3089
3090       --------------
3091       -- Fraction --
3092       --------------
3093
3094       when Attribute_Fraction =>
3095          Check_Floating_Point_Type_1;
3096          Set_Etype (N, P_Base_Type);
3097          Resolve (E1, P_Base_Type);
3098
3099       --------------
3100       -- From_Any --
3101       --------------
3102
3103       when Attribute_From_Any =>
3104          Check_E1;
3105          Check_PolyORB_Attribute;
3106          Set_Etype (N, P_Base_Type);
3107
3108       -----------------------
3109       -- Has_Access_Values --
3110       -----------------------
3111
3112       when Attribute_Has_Access_Values =>
3113          Check_Type;
3114          Check_E0;
3115          Set_Etype (N, Standard_Boolean);
3116
3117       -----------------------
3118       -- Has_Tagged_Values --
3119       -----------------------
3120
3121       when Attribute_Has_Tagged_Values =>
3122          Check_Type;
3123          Check_E0;
3124          Set_Etype (N, Standard_Boolean);
3125
3126       -----------------------
3127       -- Has_Discriminants --
3128       -----------------------
3129
3130       when Attribute_Has_Discriminants =>
3131          Legal_Formal_Attribute;
3132
3133       --------------
3134       -- Identity --
3135       --------------
3136
3137       when Attribute_Identity =>
3138          Check_E0;
3139          Analyze (P);
3140
3141          if Etype (P) =  Standard_Exception_Type then
3142             Set_Etype (N, RTE (RE_Exception_Id));
3143
3144          --  Ada 2005 (AI-345): Attribute 'Identity may be applied to
3145          --  task interface class-wide types.
3146
3147          elsif Is_Task_Type (Etype (P))
3148            or else (Is_Access_Type (Etype (P))
3149                       and then Is_Task_Type (Designated_Type (Etype (P))))
3150            or else (Ada_Version >= Ada_05
3151                       and then Ekind (Etype (P)) = E_Class_Wide_Type
3152                       and then Is_Interface (Etype (P))
3153                       and then Is_Task_Interface (Etype (P)))
3154          then
3155             Resolve (P);
3156             Set_Etype (N, RTE (RO_AT_Task_Id));
3157
3158          else
3159             if Ada_Version >= Ada_05 then
3160                Error_Attr_P
3161                  ("prefix of % attribute must be an exception, a " &
3162                   "task or a task interface class-wide object");
3163             else
3164                Error_Attr_P
3165                  ("prefix of % attribute must be a task or an exception");
3166             end if;
3167          end if;
3168
3169       -----------
3170       -- Image --
3171       -----------
3172
3173       when Attribute_Image => Image :
3174       begin
3175          Set_Etype (N, Standard_String);
3176          Check_Scalar_Type;
3177
3178          if Is_Real_Type (P_Type) then
3179             if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3180                Error_Msg_Name_1 := Aname;
3181                Error_Msg_N
3182                  ("(Ada 83) % attribute not allowed for real types", N);
3183             end if;
3184          end if;
3185
3186          if Is_Enumeration_Type (P_Type) then
3187             Check_Restriction (No_Enumeration_Maps, N);
3188          end if;
3189
3190          Check_E1;
3191          Resolve (E1, P_Base_Type);
3192          Check_Enum_Image;
3193          Validate_Non_Static_Attribute_Function_Call;
3194       end Image;
3195
3196       ---------
3197       -- Img --
3198       ---------
3199
3200       when Attribute_Img => Img :
3201       begin
3202          Check_E0;
3203          Set_Etype (N, Standard_String);
3204
3205          if not Is_Scalar_Type (P_Type)
3206            or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
3207          then
3208             Error_Attr_P
3209               ("prefix of % attribute must be scalar object name");
3210          end if;
3211
3212          Check_Enum_Image;
3213       end Img;
3214
3215       -----------
3216       -- Input --
3217       -----------
3218
3219       when Attribute_Input =>
3220          Check_E1;
3221          Check_Stream_Attribute (TSS_Stream_Input);
3222          Set_Etype (N, P_Base_Type);
3223
3224       -------------------
3225       -- Integer_Value --
3226       -------------------
3227
3228       when Attribute_Integer_Value =>
3229          Check_E1;
3230          Check_Integer_Type;
3231          Resolve (E1, Any_Fixed);
3232
3233          --  Signal an error if argument type is not a specific fixed-point
3234          --  subtype. An error has been signalled already if the argument
3235          --  was not of a fixed-point type.
3236
3237          if Etype (E1) = Any_Fixed and then not Error_Posted (E1) then
3238             Error_Attr ("argument of % must be of a fixed-point type", E1);
3239          end if;
3240
3241          Set_Etype (N, P_Base_Type);
3242
3243       -------------------
3244       -- Invalid_Value --
3245       -------------------
3246
3247       when Attribute_Invalid_Value =>
3248          Check_E0;
3249          Check_Scalar_Type;
3250          Set_Etype (N, P_Base_Type);
3251          Invalid_Value_Used := True;
3252
3253       -----------
3254       -- Large --
3255       -----------
3256
3257       when Attribute_Large =>
3258          Check_E0;
3259          Check_Real_Type;
3260          Set_Etype (N, Universal_Real);
3261
3262       ----------
3263       -- Last --
3264       ----------
3265
3266       when Attribute_Last =>
3267          Check_Array_Or_Scalar_Type;
3268
3269       --------------
3270       -- Last_Bit --
3271       --------------
3272
3273       when Attribute_Last_Bit =>
3274          Check_Component;
3275          Set_Etype (N, Universal_Integer);
3276
3277       ------------------
3278       -- Leading_Part --
3279       ------------------
3280
3281       when Attribute_Leading_Part =>
3282          Check_Floating_Point_Type_2;
3283          Set_Etype (N, P_Base_Type);
3284          Resolve (E1, P_Base_Type);
3285          Resolve (E2, Any_Integer);
3286
3287       ------------
3288       -- Length --
3289       ------------
3290
3291       when Attribute_Length =>
3292          Check_Array_Type;
3293          Set_Etype (N, Universal_Integer);
3294
3295       -------------
3296       -- Machine --
3297       -------------
3298
3299       when Attribute_Machine =>
3300          Check_Floating_Point_Type_1;
3301          Set_Etype (N, P_Base_Type);
3302          Resolve (E1, P_Base_Type);
3303
3304       ------------------
3305       -- Machine_Emax --
3306       ------------------
3307
3308       when Attribute_Machine_Emax =>
3309          Check_Floating_Point_Type_0;
3310          Set_Etype (N, Universal_Integer);
3311
3312       ------------------
3313       -- Machine_Emin --
3314       ------------------
3315
3316       when Attribute_Machine_Emin =>
3317          Check_Floating_Point_Type_0;
3318          Set_Etype (N, Universal_Integer);
3319
3320       ----------------------
3321       -- Machine_Mantissa --
3322       ----------------------
3323
3324       when Attribute_Machine_Mantissa =>
3325          Check_Floating_Point_Type_0;
3326          Set_Etype (N, Universal_Integer);
3327
3328       -----------------------
3329       -- Machine_Overflows --
3330       -----------------------
3331
3332       when Attribute_Machine_Overflows =>
3333          Check_Real_Type;
3334          Check_E0;
3335          Set_Etype (N, Standard_Boolean);
3336
3337       -------------------
3338       -- Machine_Radix --
3339       -------------------
3340
3341       when Attribute_Machine_Radix =>
3342          Check_Real_Type;
3343          Check_E0;
3344          Set_Etype (N, Universal_Integer);
3345
3346       ----------------------
3347       -- Machine_Rounding --
3348       ----------------------
3349
3350       when Attribute_Machine_Rounding =>
3351          Check_Floating_Point_Type_1;
3352          Set_Etype (N, P_Base_Type);
3353          Resolve (E1, P_Base_Type);
3354
3355       --------------------
3356       -- Machine_Rounds --
3357       --------------------
3358
3359       when Attribute_Machine_Rounds =>
3360          Check_Real_Type;
3361          Check_E0;
3362          Set_Etype (N, Standard_Boolean);
3363
3364       ------------------
3365       -- Machine_Size --
3366       ------------------
3367
3368       when Attribute_Machine_Size =>
3369          Check_E0;
3370          Check_Type;
3371          Check_Not_Incomplete_Type;
3372          Set_Etype (N, Universal_Integer);
3373
3374       --------------
3375       -- Mantissa --
3376       --------------
3377
3378       when Attribute_Mantissa =>
3379          Check_E0;
3380          Check_Real_Type;
3381          Set_Etype (N, Universal_Integer);
3382
3383       ---------
3384       -- Max --
3385       ---------
3386
3387       when Attribute_Max =>
3388          Check_E2;
3389          Check_Scalar_Type;
3390          Resolve (E1, P_Base_Type);
3391          Resolve (E2, P_Base_Type);
3392          Set_Etype (N, P_Base_Type);
3393
3394       ----------------------------------
3395       -- Max_Size_In_Storage_Elements --
3396       ----------------------------------
3397
3398       when Attribute_Max_Size_In_Storage_Elements =>
3399          Check_E0;
3400          Check_Type;
3401          Check_Not_Incomplete_Type;
3402          Set_Etype (N, Universal_Integer);
3403
3404       -----------------------
3405       -- Maximum_Alignment --
3406       -----------------------
3407
3408       when Attribute_Maximum_Alignment =>
3409          Standard_Attribute (Ttypes.Maximum_Alignment);
3410
3411       --------------------
3412       -- Mechanism_Code --
3413       --------------------
3414
3415       when Attribute_Mechanism_Code =>
3416          if not Is_Entity_Name (P)
3417            or else not Is_Subprogram (Entity (P))
3418          then
3419             Error_Attr_P ("prefix of % attribute must be subprogram");
3420          end if;
3421
3422          Check_Either_E0_Or_E1;
3423
3424          if Present (E1) then
3425             Resolve (E1, Any_Integer);
3426             Set_Etype (E1, Standard_Integer);
3427
3428             if not Is_Static_Expression (E1) then
3429                Flag_Non_Static_Expr
3430                  ("expression for parameter number must be static!", E1);
3431                Error_Attr;
3432
3433             elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
3434               or else UI_To_Int (Intval (E1)) < 0
3435             then
3436                Error_Attr ("invalid parameter number for %attribute", E1);
3437             end if;
3438          end if;
3439
3440          Set_Etype (N, Universal_Integer);
3441
3442       ---------
3443       -- Min --
3444       ---------
3445
3446       when Attribute_Min =>
3447          Check_E2;
3448          Check_Scalar_Type;
3449          Resolve (E1, P_Base_Type);
3450          Resolve (E2, P_Base_Type);
3451          Set_Etype (N, P_Base_Type);
3452
3453       ---------
3454       -- Mod --
3455       ---------
3456
3457       when Attribute_Mod =>
3458
3459          --  Note: this attribute is only allowed in Ada 2005 mode, but
3460          --  we do not need to test that here, since Mod is only recognized
3461          --  as an attribute name in Ada 2005 mode during the parse.
3462
3463          Check_E1;
3464          Check_Modular_Integer_Type;
3465          Resolve (E1, Any_Integer);
3466          Set_Etype (N, P_Base_Type);
3467
3468       -----------
3469       -- Model --
3470       -----------
3471
3472       when Attribute_Model =>
3473          Check_Floating_Point_Type_1;
3474          Set_Etype (N, P_Base_Type);
3475          Resolve (E1, P_Base_Type);
3476
3477       ----------------
3478       -- Model_Emin --
3479       ----------------
3480
3481       when Attribute_Model_Emin =>
3482          Check_Floating_Point_Type_0;
3483          Set_Etype (N, Universal_Integer);
3484
3485       -------------------
3486       -- Model_Epsilon --
3487       -------------------
3488
3489       when Attribute_Model_Epsilon =>
3490          Check_Floating_Point_Type_0;
3491          Set_Etype (N, Universal_Real);
3492
3493       --------------------
3494       -- Model_Mantissa --
3495       --------------------
3496
3497       when Attribute_Model_Mantissa =>
3498          Check_Floating_Point_Type_0;
3499          Set_Etype (N, Universal_Integer);
3500
3501       -----------------
3502       -- Model_Small --
3503       -----------------
3504
3505       when Attribute_Model_Small =>
3506          Check_Floating_Point_Type_0;
3507          Set_Etype (N, Universal_Real);
3508
3509       -------------
3510       -- Modulus --
3511       -------------
3512
3513       when Attribute_Modulus =>
3514          Check_E0;
3515          Check_Modular_Integer_Type;
3516          Set_Etype (N, Universal_Integer);
3517
3518       --------------------
3519       -- Null_Parameter --
3520       --------------------
3521
3522       when Attribute_Null_Parameter => Null_Parameter : declare
3523          Parnt  : constant Node_Id := Parent (N);
3524          GParnt : constant Node_Id := Parent (Parnt);
3525
3526          procedure Bad_Null_Parameter (Msg : String);
3527          --  Used if bad Null parameter attribute node is found. Issues
3528          --  given error message, and also sets the type to Any_Type to
3529          --  avoid blowups later on from dealing with a junk node.
3530
3531          procedure Must_Be_Imported (Proc_Ent : Entity_Id);
3532          --  Called to check that Proc_Ent is imported subprogram
3533
3534          ------------------------
3535          -- Bad_Null_Parameter --
3536          ------------------------
3537
3538          procedure Bad_Null_Parameter (Msg : String) is
3539          begin
3540             Error_Msg_N (Msg, N);
3541             Set_Etype (N, Any_Type);
3542          end Bad_Null_Parameter;
3543
3544          ----------------------
3545          -- Must_Be_Imported --
3546          ----------------------
3547
3548          procedure Must_Be_Imported (Proc_Ent : Entity_Id) is
3549             Pent : Entity_Id := Proc_Ent;
3550
3551          begin
3552             while Present (Alias (Pent)) loop
3553                Pent := Alias (Pent);
3554             end loop;
3555
3556             --  Ignore check if procedure not frozen yet (we will get
3557             --  another chance when the default parameter is reanalyzed)
3558
3559             if not Is_Frozen (Pent) then
3560                return;
3561
3562             elsif not Is_Imported (Pent) then
3563                Bad_Null_Parameter
3564                  ("Null_Parameter can only be used with imported subprogram");
3565
3566             else
3567                return;
3568             end if;
3569          end Must_Be_Imported;
3570
3571       --  Start of processing for Null_Parameter
3572
3573       begin
3574          Check_Type;
3575          Check_E0;
3576          Set_Etype (N, P_Type);
3577
3578          --  Case of attribute used as default expression
3579
3580          if Nkind (Parnt) = N_Parameter_Specification then
3581             Must_Be_Imported (Defining_Entity (GParnt));
3582
3583          --  Case of attribute used as actual for subprogram (positional)
3584
3585          elsif Nkind_In (Parnt, N_Procedure_Call_Statement,
3586                                 N_Function_Call)
3587             and then Is_Entity_Name (Name (Parnt))
3588          then
3589             Must_Be_Imported (Entity (Name (Parnt)));
3590
3591          --  Case of attribute used as actual for subprogram (named)
3592
3593          elsif Nkind (Parnt) = N_Parameter_Association
3594            and then Nkind_In (GParnt, N_Procedure_Call_Statement,
3595                                       N_Function_Call)
3596            and then Is_Entity_Name (Name (GParnt))
3597          then
3598             Must_Be_Imported (Entity (Name (GParnt)));
3599
3600          --  Not an allowed case
3601
3602          else
3603             Bad_Null_Parameter
3604               ("Null_Parameter must be actual or default parameter");
3605          end if;
3606       end Null_Parameter;
3607
3608       -----------------
3609       -- Object_Size --
3610       -----------------
3611
3612       when Attribute_Object_Size =>
3613          Check_E0;
3614          Check_Type;
3615          Check_Not_Incomplete_Type;
3616          Set_Etype (N, Universal_Integer);
3617
3618       ---------
3619       -- Old --
3620       ---------
3621
3622       when Attribute_Old =>
3623          Check_E0;
3624          Set_Etype (N, P_Type);
3625
3626          if No (Current_Subprogram) then
3627             Error_Attr ("attribute % can only appear within subprogram", N);
3628          end if;
3629
3630          if Is_Limited_Type (P_Type) then
3631             Error_Attr ("attribute % cannot apply to limited objects", P);
3632          end if;
3633
3634          if Is_Entity_Name (P)
3635            and then Is_Constant_Object (Entity (P))
3636          then
3637             Error_Msg_N
3638               ("?attribute Old applied to constant has no effect", P);
3639          end if;
3640
3641          --  Check that the expression does not refer to local entities
3642
3643          Check_Local : declare
3644             Subp : Entity_Id := Current_Subprogram;
3645
3646             function Process (N : Node_Id) return Traverse_Result;
3647             --  Check that N does not contain references to local variables
3648             --  or other local entities of Subp.
3649
3650             -------------
3651             -- Process --
3652             -------------
3653
3654             function Process (N : Node_Id) return Traverse_Result is
3655             begin
3656                if Is_Entity_Name (N)
3657                  and then not Is_Formal (Entity (N))
3658                  and then Enclosing_Subprogram (Entity (N)) = Subp
3659                then
3660                   Error_Msg_Node_1 := Entity (N);
3661                   Error_Attr
3662                     ("attribute % cannot refer to local variable&", N);
3663                end if;
3664
3665                return OK;
3666             end Process;
3667
3668             procedure Check_No_Local is new Traverse_Proc;
3669
3670          --  Start of processing for Check_Local
3671
3672          begin
3673             Check_No_Local (P);
3674
3675             if In_Parameter_Specification (P) then
3676
3677                --  We have additional restrictions on using 'Old in parameter
3678                --  specifications.
3679
3680                if Present (Enclosing_Subprogram (Current_Subprogram)) then
3681
3682                   --  Check that there is no reference to the enclosing
3683                   --  subprogram local variables. Otherwise, we might end
3684                   --  up being called from the enclosing subprogram and thus
3685                   --  using 'Old on a local variable which is not defined
3686                   --  at entry time.
3687
3688                   Subp := Enclosing_Subprogram (Current_Subprogram);
3689                   Check_No_Local (P);
3690
3691                else
3692                   --  We must prevent default expression of library-level
3693                   --  subprogram from using 'Old, as the subprogram may be
3694                   --  used in elaboration code for which there is no enclosing
3695                   --  subprogram.
3696
3697                   Error_Attr
3698                     ("attribute % can only appear within subprogram", N);
3699                end if;
3700             end if;
3701          end Check_Local;
3702
3703       ------------
3704       -- Output --
3705       ------------
3706
3707       when Attribute_Output =>
3708          Check_E2;
3709          Check_Stream_Attribute (TSS_Stream_Output);
3710          Set_Etype (N, Standard_Void_Type);
3711          Resolve (N, Standard_Void_Type);
3712
3713       ------------------
3714       -- Partition_ID --
3715       ------------------
3716
3717       when Attribute_Partition_ID => Partition_Id :
3718       begin
3719          Check_E0;
3720
3721          if P_Type /= Any_Type then
3722             if not Is_Library_Level_Entity (Entity (P)) then
3723                Error_Attr_P
3724                  ("prefix of % attribute must be library-level entity");
3725
3726             --  The defining entity of prefix should not be declared inside a
3727             --  Pure unit. RM E.1(8). Is_Pure was set during declaration.
3728
3729             elsif Is_Entity_Name (P)
3730               and then Is_Pure (Entity (P))
3731             then
3732                Error_Attr_P
3733                  ("prefix of % attribute must not be declared pure");
3734             end if;
3735          end if;
3736
3737          Set_Etype (N, Universal_Integer);
3738       end Partition_Id;
3739
3740       -------------------------
3741       -- Passed_By_Reference --
3742       -------------------------
3743
3744       when Attribute_Passed_By_Reference =>
3745          Check_E0;
3746          Check_Type;
3747          Set_Etype (N, Standard_Boolean);
3748
3749       ------------------
3750       -- Pool_Address --
3751       ------------------
3752
3753       when Attribute_Pool_Address =>
3754          Check_E0;
3755          Set_Etype (N, RTE (RE_Address));
3756
3757       ---------
3758       -- Pos --
3759       ---------
3760
3761       when Attribute_Pos =>
3762          Check_Discrete_Type;
3763          Check_E1;
3764          Resolve (E1, P_Base_Type);
3765          Set_Etype (N, Universal_Integer);
3766
3767       --------------
3768       -- Position --
3769       --------------
3770
3771       when Attribute_Position =>
3772          Check_Component;
3773          Set_Etype (N, Universal_Integer);
3774
3775       ----------
3776       -- Pred --
3777       ----------
3778
3779       when Attribute_Pred =>
3780          Check_Scalar_Type;
3781          Check_E1;
3782          Resolve (E1, P_Base_Type);
3783          Set_Etype (N, P_Base_Type);
3784
3785          --  Nothing to do for real type case
3786
3787          if Is_Real_Type (P_Type) then
3788             null;
3789
3790          --  If not modular type, test for overflow check required
3791
3792          else
3793             if not Is_Modular_Integer_Type (P_Type)
3794               and then not Range_Checks_Suppressed (P_Base_Type)
3795             then
3796                Enable_Range_Check (E1);
3797             end if;
3798          end if;
3799
3800       --------------
3801       -- Priority --
3802       --------------
3803
3804       --  Ada 2005 (AI-327): Dynamic ceiling priorities
3805
3806       when Attribute_Priority =>
3807          if Ada_Version < Ada_05 then
3808             Error_Attr ("% attribute is allowed only in Ada 2005 mode", P);
3809          end if;
3810
3811          Check_E0;
3812
3813          --  The prefix must be a protected object (AARM D.5.2 (2/2))
3814
3815          Analyze (P);
3816
3817          if Is_Protected_Type (Etype (P))
3818            or else (Is_Access_Type (Etype (P))
3819                       and then Is_Protected_Type (Designated_Type (Etype (P))))
3820          then
3821             Resolve (P, Etype (P));
3822          else
3823             Error_Attr_P ("prefix of % attribute must be a protected object");
3824          end if;
3825
3826          Set_Etype (N, Standard_Integer);
3827
3828          --  Must be called from within a protected procedure or entry of the
3829          --  protected object.
3830
3831          declare
3832             S : Entity_Id;
3833
3834          begin
3835             S := Current_Scope;
3836             while S /= Etype (P)
3837                and then S /= Standard_Standard
3838             loop
3839                S := Scope (S);
3840             end loop;
3841
3842             if S = Standard_Standard then
3843                Error_Attr ("the attribute % is only allowed inside protected "
3844                            & "operations", P);
3845             end if;
3846          end;
3847
3848          Validate_Non_Static_Attribute_Function_Call;
3849
3850       -----------
3851       -- Range --
3852       -----------
3853
3854       when Attribute_Range =>
3855          Check_Array_Or_Scalar_Type;
3856
3857          if Ada_Version = Ada_83
3858            and then Is_Scalar_Type (P_Type)
3859            and then Comes_From_Source (N)
3860          then
3861             Error_Attr
3862               ("(Ada 83) % attribute not allowed for scalar type", P);
3863          end if;
3864
3865       ------------
3866       -- Result --
3867       ------------
3868
3869       when Attribute_Result => Result : declare
3870          CS : Entity_Id := Current_Scope;
3871          PS : Entity_Id := Scope (CS);
3872
3873       begin
3874          --  If the enclosing subprogram is always inlined, the enclosing
3875          --  postcondition will not be propagated to the expanded call.
3876
3877          if Has_Pragma_Inline_Always (PS)
3878            and then Warn_On_Redundant_Constructs
3879          then
3880             Error_Msg_N
3881               ("postconditions on inlined functions not enforced?", N);
3882          end if;
3883
3884          --  If we are in the scope of a function and in Spec_Expression mode,
3885          --  this is likely the prescan of the postcondition pragma, and we
3886          --  just set the proper type. If there is an error it will be caught
3887          --  when the real Analyze call is done.
3888
3889          if Ekind (CS) = E_Function
3890            and then In_Spec_Expression
3891          then
3892             --  Check OK prefix
3893
3894             if Chars (CS) /= Chars (P) then
3895                Error_Msg_NE
3896                  ("incorrect prefix for % attribute, expected &", P, CS);
3897                Error_Attr;
3898             end if;
3899
3900             Set_Etype (N, Etype (CS));
3901
3902             --  If several functions with that name are visible,
3903             --  the intended one is the current scope.
3904
3905             if Is_Overloaded (P) then
3906                Set_Entity (P, CS);
3907                Set_Is_Overloaded (P, False);
3908             end if;
3909
3910          --  Body case, where we must be inside a generated _Postcondition
3911          --  procedure, and the prefix must be on the scope stack, or else
3912          --  the attribute use is definitely misplaced. The condition itself
3913          --  may have generated transient scopes, and is not necessarily the
3914          --  current one.
3915
3916          else
3917             while Present (CS)
3918               and then CS /= Standard_Standard
3919             loop
3920                if Chars (CS) = Name_uPostconditions then
3921                   exit;
3922                else
3923                   CS := Scope (CS);
3924                end if;
3925             end loop;
3926
3927             PS := Scope (CS);
3928
3929             if Chars (CS) = Name_uPostconditions
3930               and then Ekind (PS) = E_Function
3931             then
3932                --  Check OK prefix
3933
3934                if Nkind_In (P, N_Identifier, N_Operator_Symbol)
3935                  and then Chars (P) = Chars (PS)
3936                then
3937                   null;
3938
3939                --  Within an instance, the prefix designates the local renaming
3940                --  of the original generic.
3941
3942                elsif Is_Entity_Name (P)
3943                  and then Ekind (Entity (P)) = E_Function
3944                  and then Present (Alias (Entity (P)))
3945                  and then Chars (Alias (Entity (P))) = Chars (PS)
3946                then
3947                   null;
3948
3949                else
3950                   Error_Msg_NE
3951                     ("incorrect prefix for % attribute, expected &", P, PS);
3952                   Error_Attr;
3953                end if;
3954
3955                Rewrite (N,
3956                  Make_Identifier (Sloc (N),
3957                    Chars => Name_uResult));
3958                Analyze_And_Resolve (N, Etype (PS));
3959
3960             else
3961                Error_Attr
3962                  ("% attribute can only appear" &
3963                    "  in function Postcondition pragma", P);
3964             end if;
3965          end if;
3966       end Result;
3967
3968       ------------------
3969       -- Range_Length --
3970       ------------------
3971
3972       when Attribute_Range_Length =>
3973          Check_E0;
3974          Check_Discrete_Type;
3975          Set_Etype (N, Universal_Integer);
3976
3977       ----------
3978       -- Read --
3979       ----------
3980
3981       when Attribute_Read =>
3982          Check_E2;
3983          Check_Stream_Attribute (TSS_Stream_Read);
3984          Set_Etype (N, Standard_Void_Type);
3985          Resolve (N, Standard_Void_Type);
3986          Note_Possible_Modification (E2, Sure => True);
3987
3988       ---------------
3989       -- Remainder --
3990       ---------------
3991
3992       when Attribute_Remainder =>
3993          Check_Floating_Point_Type_2;
3994          Set_Etype (N, P_Base_Type);
3995          Resolve (E1, P_Base_Type);
3996          Resolve (E2, P_Base_Type);
3997
3998       -----------
3999       -- Round --
4000       -----------
4001
4002       when Attribute_Round =>
4003          Check_E1;
4004          Check_Decimal_Fixed_Point_Type;
4005          Set_Etype (N, P_Base_Type);
4006
4007          --  Because the context is universal_real (3.5.10(12)) it is a legal
4008          --  context for a universal fixed expression. This is the only
4009          --  attribute whose functional description involves U_R.
4010
4011          if Etype (E1) = Universal_Fixed then
4012             declare
4013                Conv : constant Node_Id := Make_Type_Conversion (Loc,
4014                   Subtype_Mark => New_Occurrence_Of (Universal_Real, Loc),
4015                   Expression   => Relocate_Node (E1));
4016
4017             begin
4018                Rewrite (E1, Conv);
4019                Analyze (E1);
4020             end;
4021          end if;
4022
4023          Resolve (E1, Any_Real);
4024
4025       --------------
4026       -- Rounding --
4027       --------------
4028
4029       when Attribute_Rounding =>
4030          Check_Floating_Point_Type_1;
4031          Set_Etype (N, P_Base_Type);
4032          Resolve (E1, P_Base_Type);
4033
4034       ---------------
4035       -- Safe_Emax --
4036       ---------------
4037
4038       when Attribute_Safe_Emax =>
4039          Check_Floating_Point_Type_0;
4040          Set_Etype (N, Universal_Integer);
4041
4042       ----------------
4043       -- Safe_First --
4044       ----------------
4045
4046       when Attribute_Safe_First =>
4047          Check_Floating_Point_Type_0;
4048          Set_Etype (N, Universal_Real);
4049
4050       ----------------
4051       -- Safe_Large --
4052       ----------------
4053
4054       when Attribute_Safe_Large =>
4055          Check_E0;
4056          Check_Real_Type;
4057          Set_Etype (N, Universal_Real);
4058
4059       ---------------
4060       -- Safe_Last --
4061       ---------------
4062
4063       when Attribute_Safe_Last =>
4064          Check_Floating_Point_Type_0;
4065          Set_Etype (N, Universal_Real);
4066
4067       ----------------
4068       -- Safe_Small --
4069       ----------------
4070
4071       when Attribute_Safe_Small =>
4072          Check_E0;
4073          Check_Real_Type;
4074          Set_Etype (N, Universal_Real);
4075
4076       -----------
4077       -- Scale --
4078       -----------
4079
4080       when Attribute_Scale =>
4081          Check_E0;
4082          Check_Decimal_Fixed_Point_Type;
4083          Set_Etype (N, Universal_Integer);
4084
4085       -------------
4086       -- Scaling --
4087       -------------
4088
4089       when Attribute_Scaling =>
4090          Check_Floating_Point_Type_2;
4091          Set_Etype (N, P_Base_Type);
4092          Resolve (E1, P_Base_Type);
4093
4094       ------------------
4095       -- Signed_Zeros --
4096       ------------------
4097
4098       when Attribute_Signed_Zeros =>
4099          Check_Floating_Point_Type_0;
4100          Set_Etype (N, Standard_Boolean);
4101
4102       ----------
4103       -- Size --
4104       ----------
4105
4106       when Attribute_Size | Attribute_VADS_Size => Size :
4107       begin
4108          Check_E0;
4109
4110          --  If prefix is parameterless function call, rewrite and resolve
4111          --  as such.
4112
4113          if Is_Entity_Name (P)
4114            and then Ekind (Entity (P)) = E_Function
4115          then
4116             Resolve (P);
4117
4118          --  Similar processing for a protected function call
4119
4120          elsif Nkind (P) = N_Selected_Component
4121            and then Ekind (Entity (Selector_Name (P))) = E_Function
4122          then
4123             Resolve (P);
4124          end if;
4125
4126          if Is_Object_Reference (P) then
4127             Check_Object_Reference (P);
4128
4129          elsif Is_Entity_Name (P)
4130            and then (Is_Type (Entity (P))
4131                        or else Ekind (Entity (P)) = E_Enumeration_Literal)
4132          then
4133             null;
4134
4135          elsif Nkind (P) = N_Type_Conversion
4136            and then not Comes_From_Source (P)
4137          then
4138             null;
4139
4140          else
4141             Error_Attr_P ("invalid prefix for % attribute");
4142          end if;
4143
4144          Check_Not_Incomplete_Type;
4145          Check_Not_CPP_Type;
4146          Set_Etype (N, Universal_Integer);
4147       end Size;
4148
4149       -----------
4150       -- Small --
4151       -----------
4152
4153       when Attribute_Small =>
4154          Check_E0;
4155          Check_Real_Type;
4156          Set_Etype (N, Universal_Real);
4157
4158       ------------------
4159       -- Storage_Pool --
4160       ------------------
4161
4162       when Attribute_Storage_Pool => Storage_Pool :
4163       begin
4164          Check_E0;
4165
4166          if Is_Access_Type (P_Type) then
4167             if Ekind (P_Type) = E_Access_Subprogram_Type then
4168                Error_Attr_P
4169                  ("cannot use % attribute for access-to-subprogram type");
4170             end if;
4171
4172             --  Set appropriate entity
4173
4174             if Present (Associated_Storage_Pool (Root_Type (P_Type))) then
4175                Set_Entity (N, Associated_Storage_Pool (Root_Type (P_Type)));
4176             else
4177                Set_Entity (N, RTE (RE_Global_Pool_Object));
4178             end if;
4179
4180             Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
4181
4182             --  Validate_Remote_Access_To_Class_Wide_Type for attribute
4183             --  Storage_Pool since this attribute is not defined for such
4184             --  types (RM E.2.3(22)).
4185
4186             Validate_Remote_Access_To_Class_Wide_Type (N);
4187
4188          else
4189             Error_Attr_P ("prefix of % attribute must be access type");
4190          end if;
4191       end Storage_Pool;
4192
4193       ------------------
4194       -- Storage_Size --
4195       ------------------
4196
4197       when Attribute_Storage_Size => Storage_Size :
4198       begin
4199          Check_E0;
4200
4201          if Is_Task_Type (P_Type) then
4202             Set_Etype (N, Universal_Integer);
4203
4204          elsif Is_Access_Type (P_Type) then
4205             if Ekind (P_Type) = E_Access_Subprogram_Type then
4206                Error_Attr_P
4207                  ("cannot use % attribute for access-to-subprogram type");
4208             end if;
4209
4210             if Is_Entity_Name (P)
4211               and then Is_Type (Entity (P))
4212             then
4213                Check_Type;
4214                Set_Etype (N, Universal_Integer);
4215
4216                --   Validate_Remote_Access_To_Class_Wide_Type for attribute
4217                --   Storage_Size since this attribute is not defined for
4218                --   such types (RM E.2.3(22)).
4219
4220                Validate_Remote_Access_To_Class_Wide_Type (N);
4221
4222             --  The prefix is allowed to be an implicit dereference
4223             --  of an access value designating a task.
4224
4225             else
4226                Check_Task_Prefix;
4227                Set_Etype (N, Universal_Integer);
4228             end if;
4229
4230          else
4231             Error_Attr_P ("prefix of % attribute must be access or task type");
4232          end if;
4233       end Storage_Size;
4234
4235       ------------------
4236       -- Storage_Unit --
4237       ------------------
4238
4239       when Attribute_Storage_Unit =>
4240          Standard_Attribute (Ttypes.System_Storage_Unit);
4241
4242       -----------------
4243       -- Stream_Size --
4244       -----------------
4245
4246       when Attribute_Stream_Size =>
4247          Check_E0;
4248          Check_Type;
4249
4250          if Is_Entity_Name (P)
4251            and then Is_Elementary_Type (Entity (P))
4252          then
4253             Set_Etype (N, Universal_Integer);
4254          else
4255             Error_Attr_P ("invalid prefix for % attribute");
4256          end if;
4257
4258       ---------------
4259       -- Stub_Type --
4260       ---------------
4261
4262       when Attribute_Stub_Type =>
4263          Check_Type;
4264          Check_E0;
4265
4266          if Is_Remote_Access_To_Class_Wide_Type (P_Type) then
4267             Rewrite (N,
4268               New_Occurrence_Of (Corresponding_Stub_Type (P_Type), Loc));
4269          else
4270             Error_Attr_P
4271               ("prefix of% attribute must be remote access to classwide");
4272          end if;
4273
4274       ----------
4275       -- Succ --
4276       ----------
4277
4278       when Attribute_Succ =>
4279          Check_Scalar_Type;
4280          Check_E1;
4281          Resolve (E1, P_Base_Type);
4282          Set_Etype (N, P_Base_Type);
4283
4284          --  Nothing to do for real type case
4285
4286          if Is_Real_Type (P_Type) then
4287             null;
4288
4289          --  If not modular type, test for overflow check required
4290
4291          else
4292             if not Is_Modular_Integer_Type (P_Type)
4293               and then not Range_Checks_Suppressed (P_Base_Type)
4294             then
4295                Enable_Range_Check (E1);
4296             end if;
4297          end if;
4298
4299       ---------
4300       -- Tag --
4301       ---------
4302
4303       when Attribute_Tag => Tag :
4304       begin
4305          Check_E0;
4306          Check_Dereference;
4307
4308          if not Is_Tagged_Type (P_Type) then
4309             Error_Attr_P ("prefix of % attribute must be tagged");
4310
4311          --  Next test does not apply to generated code
4312          --  why not, and what does the illegal reference mean???
4313
4314          elsif Is_Object_Reference (P)
4315            and then not Is_Class_Wide_Type (P_Type)
4316            and then Comes_From_Source (N)
4317          then
4318             Error_Attr_P
4319               ("% attribute can only be applied to objects " &
4320                "of class - wide type");
4321          end if;
4322
4323          --  The prefix cannot be an incomplete type. However, references
4324          --  to 'Tag can be generated when expanding interface conversions,
4325          --  and this is legal.
4326
4327          if Comes_From_Source (N) then
4328             Check_Not_Incomplete_Type;
4329          end if;
4330
4331          --  Set appropriate type
4332
4333          Set_Etype (N, RTE (RE_Tag));
4334       end Tag;
4335
4336       -----------------
4337       -- Target_Name --
4338       -----------------
4339
4340       when Attribute_Target_Name => Target_Name : declare
4341          TN : constant String := Sdefault.Target_Name.all;
4342          TL : Natural;
4343
4344       begin
4345          Check_Standard_Prefix;
4346
4347          TL := TN'Last;
4348
4349          if TN (TL) = '/' or else TN (TL) = '\' then
4350             TL := TL - 1;
4351          end if;
4352
4353          Rewrite (N,
4354            Make_String_Literal (Loc,
4355              Strval => TN (TN'First .. TL)));
4356          Analyze_And_Resolve (N, Standard_String);
4357       end Target_Name;
4358
4359       ----------------
4360       -- Terminated --
4361       ----------------
4362
4363       when Attribute_Terminated =>
4364          Check_E0;
4365          Set_Etype (N, Standard_Boolean);
4366          Check_Task_Prefix;
4367
4368       ----------------
4369       -- To_Address --
4370       ----------------
4371
4372       when Attribute_To_Address =>
4373          Check_E1;
4374          Analyze (P);
4375
4376          if Nkind (P) /= N_Identifier
4377            or else Chars (P) /= Name_System
4378          then
4379             Error_Attr_P ("prefix of %attribute must be System");
4380          end if;
4381
4382          Generate_Reference (RTE (RE_Address), P);
4383          Analyze_And_Resolve (E1, Any_Integer);
4384          Set_Etype (N, RTE (RE_Address));
4385
4386       ------------
4387       -- To_Any --
4388       ------------
4389
4390       when Attribute_To_Any =>
4391          Check_E1;
4392          Check_PolyORB_Attribute;
4393          Set_Etype (N, RTE (RE_Any));
4394
4395       ----------------
4396       -- Truncation --
4397       ----------------
4398
4399       when Attribute_Truncation =>
4400          Check_Floating_Point_Type_1;
4401          Resolve (E1, P_Base_Type);
4402          Set_Etype (N, P_Base_Type);
4403
4404       ----------------
4405       -- Type_Class --
4406       ----------------
4407
4408       when Attribute_Type_Class =>
4409          Check_E0;
4410          Check_Type;
4411          Check_Not_Incomplete_Type;
4412          Set_Etype (N, RTE (RE_Type_Class));
4413
4414       --------------
4415       -- TypeCode --
4416       --------------
4417
4418       when Attribute_TypeCode =>
4419          Check_E0;
4420          Check_PolyORB_Attribute;
4421          Set_Etype (N, RTE (RE_TypeCode));
4422
4423       -----------------
4424       -- UET_Address --
4425       -----------------
4426
4427       when Attribute_UET_Address =>
4428          Check_E0;
4429          Check_Unit_Name (P);
4430          Set_Etype (N, RTE (RE_Address));
4431
4432       -----------------------
4433       -- Unbiased_Rounding --
4434       -----------------------
4435
4436       when Attribute_Unbiased_Rounding =>
4437          Check_Floating_Point_Type_1;
4438          Set_Etype (N, P_Base_Type);
4439          Resolve (E1, P_Base_Type);
4440
4441       ----------------------
4442       -- Unchecked_Access --
4443       ----------------------
4444
4445       when Attribute_Unchecked_Access =>
4446          if Comes_From_Source (N) then
4447             Check_Restriction (No_Unchecked_Access, N);
4448          end if;
4449
4450          Analyze_Access_Attribute;
4451
4452       -------------------------
4453       -- Unconstrained_Array --
4454       -------------------------
4455
4456       when Attribute_Unconstrained_Array =>
4457          Check_E0;
4458          Check_Type;
4459          Check_Not_Incomplete_Type;
4460          Set_Etype (N, Standard_Boolean);
4461
4462       ------------------------------
4463       -- Universal_Literal_String --
4464       ------------------------------
4465
4466       --  This is a GNAT specific attribute whose prefix must be a named
4467       --  number where the expression is either a single numeric literal,
4468       --  or a numeric literal immediately preceded by a minus sign. The
4469       --  result is equivalent to a string literal containing the text of
4470       --  the literal as it appeared in the source program with a possible
4471       --  leading minus sign.
4472
4473       when Attribute_Universal_Literal_String => Universal_Literal_String :
4474       begin
4475          Check_E0;
4476
4477          if not Is_Entity_Name (P)
4478            or else Ekind (Entity (P)) not in Named_Kind
4479          then
4480             Error_Attr_P ("prefix for % attribute must be named number");
4481
4482          else
4483             declare
4484                Expr     : Node_Id;
4485                Negative : Boolean;
4486                S        : Source_Ptr;
4487                Src      : Source_Buffer_Ptr;
4488
4489             begin
4490                Expr := Original_Node (Expression (Parent (Entity (P))));
4491
4492                if Nkind (Expr) = N_Op_Minus then
4493                   Negative := True;
4494                   Expr := Original_Node (Right_Opnd (Expr));
4495                else
4496                   Negative := False;
4497                end if;
4498
4499                if not Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) then
4500                   Error_Attr
4501                     ("named number for % attribute must be simple literal", N);
4502                end if;
4503
4504                --  Build string literal corresponding to source literal text
4505
4506                Start_String;
4507
4508                if Negative then
4509                   Store_String_Char (Get_Char_Code ('-'));
4510                end if;
4511
4512                S := Sloc (Expr);
4513                Src := Source_Text (Get_Source_File_Index (S));
4514
4515                while Src (S) /= ';' and then Src (S) /= ' ' loop
4516                   Store_String_Char (Get_Char_Code (Src (S)));
4517                   S := S + 1;
4518                end loop;
4519
4520                --  Now we rewrite the attribute with the string literal
4521
4522                Rewrite (N,
4523                  Make_String_Literal (Loc, End_String));
4524                Analyze (N);
4525             end;
4526          end if;
4527       end Universal_Literal_String;
4528
4529       -------------------------
4530       -- Unrestricted_Access --
4531       -------------------------
4532
4533       --  This is a GNAT specific attribute which is like Access except that
4534       --  all scope checks and checks for aliased views are omitted.
4535
4536       when Attribute_Unrestricted_Access =>
4537          if Comes_From_Source (N) then
4538             Check_Restriction (No_Unchecked_Access, N);
4539          end if;
4540
4541          if Is_Entity_Name (P) then
4542             Set_Address_Taken (Entity (P));
4543          end if;
4544
4545          Analyze_Access_Attribute;
4546
4547       ---------
4548       -- Val --
4549       ---------
4550
4551       when Attribute_Val => Val : declare
4552       begin
4553          Check_E1;
4554          Check_Discrete_Type;
4555          Resolve (E1, Any_Integer);
4556          Set_Etype (N, P_Base_Type);
4557
4558          --  Note, we need a range check in general, but we wait for the
4559          --  Resolve call to do this, since we want to let Eval_Attribute
4560          --  have a chance to find an static illegality first!
4561       end Val;
4562
4563       -----------
4564       -- Valid --
4565       -----------
4566
4567       when Attribute_Valid =>
4568          Check_E0;
4569
4570          --  Ignore check for object if we have a 'Valid reference generated
4571          --  by the expanded code, since in some cases valid checks can occur
4572          --  on items that are names, but are not objects (e.g. attributes).
4573
4574          if Comes_From_Source (N) then
4575             Check_Object_Reference (P);
4576          end if;
4577
4578          if not Is_Scalar_Type (P_Type) then
4579             Error_Attr_P ("object for % attribute must be of scalar type");
4580          end if;
4581
4582          Set_Etype (N, Standard_Boolean);
4583
4584       -----------
4585       -- Value --
4586       -----------
4587
4588       when Attribute_Value => Value :
4589       begin
4590          Check_E1;
4591          Check_Scalar_Type;
4592
4593          --  Case of enumeration type
4594
4595          if Is_Enumeration_Type (P_Type) then
4596             Check_Restriction (No_Enumeration_Maps, N);
4597
4598             --  Mark all enumeration literals as referenced, since the use of
4599             --  the Value attribute can implicitly reference any of the
4600             --  literals of the enumeration base type.
4601
4602             declare
4603                Ent : Entity_Id := First_Literal (P_Base_Type);
4604             begin
4605                while Present (Ent) loop
4606                   Set_Referenced (Ent);
4607                   Next_Literal (Ent);
4608                end loop;
4609             end;
4610          end if;
4611
4612          --  Set Etype before resolving expression because expansion of
4613          --  expression may require enclosing type. Note that the type
4614          --  returned by 'Value is the base type of the prefix type.
4615
4616          Set_Etype (N, P_Base_Type);
4617          Validate_Non_Static_Attribute_Function_Call;
4618       end Value;
4619
4620       ----------------
4621       -- Value_Size --
4622       ----------------
4623
4624       when Attribute_Value_Size =>
4625          Check_E0;
4626          Check_Type;
4627          Check_Not_Incomplete_Type;
4628          Set_Etype (N, Universal_Integer);
4629
4630       -------------
4631       -- Version --
4632       -------------
4633
4634       when Attribute_Version =>
4635          Check_E0;
4636          Check_Program_Unit;
4637          Set_Etype (N, RTE (RE_Version_String));
4638
4639       ------------------
4640       -- Wchar_T_Size --
4641       ------------------
4642
4643       when Attribute_Wchar_T_Size =>
4644          Standard_Attribute (Interfaces_Wchar_T_Size);
4645
4646       ----------------
4647       -- Wide_Image --
4648       ----------------
4649
4650       when Attribute_Wide_Image => Wide_Image :
4651       begin
4652          Check_Scalar_Type;
4653          Set_Etype (N, Standard_Wide_String);
4654          Check_E1;
4655          Resolve (E1, P_Base_Type);
4656          Validate_Non_Static_Attribute_Function_Call;
4657       end Wide_Image;
4658
4659       ---------------------
4660       -- Wide_Wide_Image --
4661       ---------------------
4662
4663       when Attribute_Wide_Wide_Image => Wide_Wide_Image :
4664       begin
4665          Check_Scalar_Type;
4666          Set_Etype (N, Standard_Wide_Wide_String);
4667          Check_E1;
4668          Resolve (E1, P_Base_Type);
4669          Validate_Non_Static_Attribute_Function_Call;
4670       end Wide_Wide_Image;
4671
4672       ----------------
4673       -- Wide_Value --
4674       ----------------
4675
4676       when Attribute_Wide_Value => Wide_Value :
4677       begin
4678          Check_E1;
4679          Check_Scalar_Type;
4680
4681          --  Set Etype before resolving expression because expansion
4682          --  of expression may require enclosing type.
4683
4684          Set_Etype (N, P_Type);
4685          Validate_Non_Static_Attribute_Function_Call;
4686       end Wide_Value;
4687
4688       ---------------------
4689       -- Wide_Wide_Value --
4690       ---------------------
4691
4692       when Attribute_Wide_Wide_Value => Wide_Wide_Value :
4693       begin
4694          Check_E1;
4695          Check_Scalar_Type;
4696
4697          --  Set Etype before resolving expression because expansion
4698          --  of expression may require enclosing type.
4699
4700          Set_Etype (N, P_Type);
4701          Validate_Non_Static_Attribute_Function_Call;
4702       end Wide_Wide_Value;
4703
4704       ---------------------
4705       -- Wide_Wide_Width --
4706       ---------------------
4707
4708       when Attribute_Wide_Wide_Width =>
4709          Check_E0;
4710          Check_Scalar_Type;
4711          Set_Etype (N, Universal_Integer);
4712
4713       ----------------
4714       -- Wide_Width --
4715       ----------------
4716
4717       when Attribute_Wide_Width =>
4718          Check_E0;
4719          Check_Scalar_Type;
4720          Set_Etype (N, Universal_Integer);
4721
4722       -----------
4723       -- Width --
4724       -----------
4725
4726       when Attribute_Width =>
4727          Check_E0;
4728          Check_Scalar_Type;
4729          Set_Etype (N, Universal_Integer);
4730
4731       ---------------
4732       -- Word_Size --
4733       ---------------
4734
4735       when Attribute_Word_Size =>
4736          Standard_Attribute (System_Word_Size);
4737
4738       -----------
4739       -- Write --
4740       -----------
4741
4742       when Attribute_Write =>
4743          Check_E2;
4744          Check_Stream_Attribute (TSS_Stream_Write);
4745          Set_Etype (N, Standard_Void_Type);
4746          Resolve (N, Standard_Void_Type);
4747
4748       end case;
4749
4750    --  All errors raise Bad_Attribute, so that we get out before any further
4751    --  damage occurs when an error is detected (for example, if we check for
4752    --  one attribute expression, and the check succeeds, we want to be able
4753    --  to proceed securely assuming that an expression is in fact present.
4754
4755    --  Note: we set the attribute analyzed in this case to prevent any
4756    --  attempt at reanalysis which could generate spurious error msgs.
4757
4758    exception
4759       when Bad_Attribute =>
4760          Set_Analyzed (N);
4761          Set_Etype (N, Any_Type);
4762          return;
4763    end Analyze_Attribute;
4764
4765    --------------------
4766    -- Eval_Attribute --
4767    --------------------
4768
4769    procedure Eval_Attribute (N : Node_Id) is
4770       Loc   : constant Source_Ptr   := Sloc (N);
4771       Aname : constant Name_Id      := Attribute_Name (N);
4772       Id    : constant Attribute_Id := Get_Attribute_Id (Aname);
4773       P     : constant Node_Id      := Prefix (N);
4774
4775       C_Type : constant Entity_Id := Etype (N);
4776       --  The type imposed by the context
4777
4778       E1 : Node_Id;
4779       --  First expression, or Empty if none
4780
4781       E2 : Node_Id;
4782       --  Second expression, or Empty if none
4783
4784       P_Entity : Entity_Id;
4785       --  Entity denoted by prefix
4786
4787       P_Type : Entity_Id;
4788       --  The type of the prefix
4789
4790       P_Base_Type : Entity_Id;
4791       --  The base type of the prefix type
4792
4793       P_Root_Type : Entity_Id;
4794       --  The root type of the prefix type
4795
4796       Static : Boolean;
4797       --  True if the result is Static. This is set by the general processing
4798       --  to true if the prefix is static, and all expressions are static. It
4799       --  can be reset as processing continues for particular attributes
4800
4801       Lo_Bound, Hi_Bound : Node_Id;
4802       --  Expressions for low and high bounds of type or array index referenced
4803       --  by First, Last, or Length attribute for array, set by Set_Bounds.
4804
4805       CE_Node : Node_Id;
4806       --  Constraint error node used if we have an attribute reference has
4807       --  an argument that raises a constraint error. In this case we replace
4808       --  the attribute with a raise constraint_error node. This is important
4809       --  processing, since otherwise gigi might see an attribute which it is
4810       --  unprepared to deal with.
4811
4812       function Aft_Value return Nat;
4813       --  Computes Aft value for current attribute prefix (used by Aft itself
4814       --  and also by Width for computing the Width of a fixed point type).
4815
4816       procedure Check_Expressions;
4817       --  In case where the attribute is not foldable, the expressions, if
4818       --  any, of the attribute, are in a non-static context. This procedure
4819       --  performs the required additional checks.
4820
4821       function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean;
4822       --  Determines if the given type has compile time known bounds. Note
4823       --  that we enter the case statement even in cases where the prefix
4824       --  type does NOT have known bounds, so it is important to guard any
4825       --  attempt to evaluate both bounds with a call to this function.
4826
4827       procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint);
4828       --  This procedure is called when the attribute N has a non-static
4829       --  but compile time known value given by Val. It includes the
4830       --  necessary checks for out of range values.
4831
4832       procedure Float_Attribute_Universal_Integer
4833         (IEEES_Val : Int;
4834          IEEEL_Val : Int;
4835          IEEEX_Val : Int;
4836          VAXFF_Val : Int;
4837          VAXDF_Val : Int;
4838          VAXGF_Val : Int;
4839          AAMPS_Val : Int;
4840          AAMPL_Val : Int);
4841       --  This procedure evaluates a float attribute with no arguments that
4842       --  returns a universal integer result. The parameters give the values
4843       --  for the possible floating-point root types. See ttypef for details.
4844       --  The prefix type is a float type (and is thus not a generic type).
4845
4846       procedure Float_Attribute_Universal_Real
4847         (IEEES_Val : String;
4848          IEEEL_Val : String;
4849          IEEEX_Val : String;
4850          VAXFF_Val : String;
4851          VAXDF_Val : String;
4852          VAXGF_Val : String;
4853          AAMPS_Val : String;
4854          AAMPL_Val : String);
4855       --  This procedure evaluates a float attribute with no arguments that
4856       --  returns a universal real result. The parameters give the values
4857       --  required for the possible floating-point root types in string
4858       --  format as real literals with a possible leading minus sign.
4859       --  The prefix type is a float type (and is thus not a generic type).
4860
4861       function Fore_Value return Nat;
4862       --  Computes the Fore value for the current attribute prefix, which is
4863       --  known to be a static fixed-point type. Used by Fore and Width.
4864
4865       function Mantissa return Uint;
4866       --  Returns the Mantissa value for the prefix type
4867
4868       procedure Set_Bounds;
4869       --  Used for First, Last and Length attributes applied to an array or
4870       --  array subtype. Sets the variables Lo_Bound and Hi_Bound to the low
4871       --  and high bound expressions for the index referenced by the attribute
4872       --  designator (i.e. the first index if no expression is present, and
4873       --  the N'th index if the value N is present as an expression). Also
4874       --  used for First and Last of scalar types. Static is reset to False
4875       --  if the type or index type is not statically constrained.
4876
4877       function Statically_Denotes_Entity (N : Node_Id) return Boolean;
4878       --  Verify that the prefix of a potentially static array attribute
4879       --  satisfies the conditions of 4.9 (14).
4880
4881       ---------------
4882       -- Aft_Value --
4883       ---------------
4884
4885       function Aft_Value return Nat is
4886          Result    : Nat;
4887          Delta_Val : Ureal;
4888
4889       begin
4890          Result := 1;
4891          Delta_Val := Delta_Value (P_Type);
4892          while Delta_Val < Ureal_Tenth loop
4893             Delta_Val := Delta_Val * Ureal_10;
4894             Result := Result + 1;
4895          end loop;
4896
4897          return Result;
4898       end Aft_Value;
4899
4900       -----------------------
4901       -- Check_Expressions --
4902       -----------------------
4903
4904       procedure Check_Expressions is
4905          E : Node_Id;
4906       begin
4907          E := E1;
4908          while Present (E) loop
4909             Check_Non_Static_Context (E);
4910             Next (E);
4911          end loop;
4912       end Check_Expressions;
4913
4914       ----------------------------------
4915       -- Compile_Time_Known_Attribute --
4916       ----------------------------------
4917
4918       procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint) is
4919          T : constant Entity_Id := Etype (N);
4920
4921       begin
4922          Fold_Uint (N, Val, False);
4923
4924          --  Check that result is in bounds of the type if it is static
4925
4926          if Is_In_Range (N, T, Assume_Valid => False) then
4927             null;
4928
4929          elsif Is_Out_Of_Range (N, T) then
4930             Apply_Compile_Time_Constraint_Error
4931               (N, "value not in range of}?", CE_Range_Check_Failed);
4932
4933          elsif not Range_Checks_Suppressed (T) then
4934             Enable_Range_Check (N);
4935
4936          else
4937             Set_Do_Range_Check (N, False);
4938          end if;
4939       end Compile_Time_Known_Attribute;
4940
4941       -------------------------------
4942       -- Compile_Time_Known_Bounds --
4943       -------------------------------
4944
4945       function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean is
4946       begin
4947          return
4948            Compile_Time_Known_Value (Type_Low_Bound (Typ))
4949              and then
4950            Compile_Time_Known_Value (Type_High_Bound (Typ));
4951       end Compile_Time_Known_Bounds;
4952
4953       ---------------------------------------
4954       -- Float_Attribute_Universal_Integer --
4955       ---------------------------------------
4956
4957       procedure Float_Attribute_Universal_Integer
4958         (IEEES_Val : Int;
4959          IEEEL_Val : Int;
4960          IEEEX_Val : Int;
4961          VAXFF_Val : Int;
4962          VAXDF_Val : Int;
4963          VAXGF_Val : Int;
4964          AAMPS_Val : Int;
4965          AAMPL_Val : Int)
4966       is
4967          Val  : Int;
4968          Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
4969
4970       begin
4971          if Vax_Float (P_Base_Type) then
4972             if Digs = VAXFF_Digits then
4973                Val := VAXFF_Val;
4974             elsif Digs = VAXDF_Digits then
4975                Val := VAXDF_Val;
4976             else pragma Assert (Digs = VAXGF_Digits);
4977                Val := VAXGF_Val;
4978             end if;
4979
4980          elsif Is_AAMP_Float (P_Base_Type) then
4981             if Digs = AAMPS_Digits then
4982                Val := AAMPS_Val;
4983             else pragma Assert (Digs = AAMPL_Digits);
4984                Val := AAMPL_Val;
4985             end if;
4986
4987          else
4988             if Digs = IEEES_Digits then
4989                Val := IEEES_Val;
4990             elsif Digs = IEEEL_Digits then
4991                Val := IEEEL_Val;
4992             else pragma Assert (Digs = IEEEX_Digits);
4993                Val := IEEEX_Val;
4994             end if;
4995          end if;
4996
4997          Fold_Uint (N, UI_From_Int (Val), True);
4998       end Float_Attribute_Universal_Integer;
4999
5000       ------------------------------------
5001       -- Float_Attribute_Universal_Real --
5002       ------------------------------------
5003
5004       procedure Float_Attribute_Universal_Real
5005         (IEEES_Val : String;
5006          IEEEL_Val : String;
5007          IEEEX_Val : String;
5008          VAXFF_Val : String;
5009          VAXDF_Val : String;
5010          VAXGF_Val : String;
5011          AAMPS_Val : String;
5012          AAMPL_Val : String)
5013       is
5014          Val  : Node_Id;
5015          Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
5016
5017       begin
5018          if Vax_Float (P_Base_Type) then
5019             if Digs = VAXFF_Digits then
5020                Val := Real_Convert (VAXFF_Val);
5021             elsif Digs = VAXDF_Digits then
5022                Val := Real_Convert (VAXDF_Val);
5023             else pragma Assert (Digs = VAXGF_Digits);
5024                Val := Real_Convert (VAXGF_Val);
5025             end if;
5026
5027          elsif Is_AAMP_Float (P_Base_Type) then
5028             if Digs = AAMPS_Digits then
5029                Val := Real_Convert (AAMPS_Val);
5030             else pragma Assert (Digs = AAMPL_Digits);
5031                Val := Real_Convert (AAMPL_Val);
5032             end if;
5033
5034          else
5035             if Digs = IEEES_Digits then
5036                Val := Real_Convert (IEEES_Val);
5037             elsif Digs = IEEEL_Digits then
5038                Val := Real_Convert (IEEEL_Val);
5039             else pragma Assert (Digs = IEEEX_Digits);
5040                Val := Real_Convert (IEEEX_Val);
5041             end if;
5042          end if;
5043
5044          Set_Sloc (Val, Loc);
5045          Rewrite (N, Val);
5046          Set_Is_Static_Expression (N, Static);
5047          Analyze_And_Resolve (N, C_Type);
5048       end Float_Attribute_Universal_Real;
5049
5050       ----------------
5051       -- Fore_Value --
5052       ----------------
5053
5054       --  Note that the Fore calculation is based on the actual values
5055       --  of the bounds, and does not take into account possible rounding.
5056
5057       function Fore_Value return Nat is
5058          Lo      : constant Uint  := Expr_Value (Type_Low_Bound (P_Type));
5059          Hi      : constant Uint  := Expr_Value (Type_High_Bound (P_Type));
5060          Small   : constant Ureal := Small_Value (P_Type);
5061          Lo_Real : constant Ureal := Lo * Small;
5062          Hi_Real : constant Ureal := Hi * Small;
5063          T       : Ureal;
5064          R       : Nat;
5065
5066       begin
5067          --  Bounds are given in terms of small units, so first compute
5068          --  proper values as reals.
5069
5070          T := UR_Max (abs Lo_Real, abs Hi_Real);
5071          R := 2;
5072
5073          --  Loop to compute proper value if more than one digit required
5074
5075          while T >= Ureal_10 loop
5076             R := R + 1;
5077             T := T / Ureal_10;
5078          end loop;
5079
5080          return R;
5081       end Fore_Value;
5082
5083       --------------
5084       -- Mantissa --
5085       --------------
5086
5087       --  Table of mantissa values accessed by function  Computed using
5088       --  the relation:
5089
5090       --    T'Mantissa = integer next above (D * log(10)/log(2)) + 1)
5091
5092       --  where D is T'Digits (RM83 3.5.7)
5093
5094       Mantissa_Value : constant array (Nat range 1 .. 40) of Nat := (
5095           1 =>   5,
5096           2 =>   8,
5097           3 =>  11,
5098           4 =>  15,
5099           5 =>  18,
5100           6 =>  21,
5101           7 =>  25,
5102           8 =>  28,
5103           9 =>  31,
5104          10 =>  35,
5105          11 =>  38,
5106          12 =>  41,
5107          13 =>  45,
5108          14 =>  48,
5109          15 =>  51,
5110          16 =>  55,
5111          17 =>  58,
5112          18 =>  61,
5113          19 =>  65,
5114          20 =>  68,
5115          21 =>  71,
5116          22 =>  75,
5117          23 =>  78,
5118          24 =>  81,
5119          25 =>  85,
5120          26 =>  88,
5121          27 =>  91,
5122          28 =>  95,
5123          29 =>  98,
5124          30 => 101,
5125          31 => 104,
5126          32 => 108,
5127          33 => 111,
5128          34 => 114,
5129          35 => 118,
5130          36 => 121,
5131          37 => 124,
5132          38 => 128,
5133          39 => 131,
5134          40 => 134);
5135
5136       function Mantissa return Uint is
5137       begin
5138          return
5139            UI_From_Int (Mantissa_Value (UI_To_Int (Digits_Value (P_Type))));
5140       end Mantissa;
5141
5142       ----------------
5143       -- Set_Bounds --
5144       ----------------
5145
5146       procedure Set_Bounds is
5147          Ndim : Nat;
5148          Indx : Node_Id;
5149          Ityp : Entity_Id;
5150
5151       begin
5152          --  For a string literal subtype, we have to construct the bounds.
5153          --  Valid Ada code never applies attributes to string literals, but
5154          --  it is convenient to allow the expander to generate attribute
5155          --  references of this type (e.g. First and Last applied to a string
5156          --  literal).
5157
5158          --  Note that the whole point of the E_String_Literal_Subtype is to
5159          --  avoid this construction of bounds, but the cases in which we
5160          --  have to materialize them are rare enough that we don't worry!
5161
5162          --  The low bound is simply the low bound of the base type. The
5163          --  high bound is computed from the length of the string and this
5164          --  low bound.
5165
5166          if Ekind (P_Type) = E_String_Literal_Subtype then
5167             Ityp := Etype (First_Index (Base_Type (P_Type)));
5168             Lo_Bound := Type_Low_Bound (Ityp);
5169
5170             Hi_Bound :=
5171               Make_Integer_Literal (Sloc (P),
5172                 Intval =>
5173                   Expr_Value (Lo_Bound) + String_Literal_Length (P_Type) - 1);
5174
5175             Set_Parent (Hi_Bound, P);
5176             Analyze_And_Resolve (Hi_Bound, Etype (Lo_Bound));
5177             return;
5178
5179          --  For non-array case, just get bounds of scalar type
5180
5181          elsif Is_Scalar_Type (P_Type) then
5182             Ityp := P_Type;
5183
5184             --  For a fixed-point type, we must freeze to get the attributes
5185             --  of the fixed-point type set now so we can reference them.
5186
5187             if Is_Fixed_Point_Type (P_Type)
5188               and then not Is_Frozen (Base_Type (P_Type))
5189               and then Compile_Time_Known_Value (Type_Low_Bound (P_Type))
5190               and then Compile_Time_Known_Value (Type_High_Bound (P_Type))
5191             then
5192                Freeze_Fixed_Point_Type (Base_Type (P_Type));
5193             end if;
5194
5195          --  For array case, get type of proper index
5196
5197          else
5198             if No (E1) then
5199                Ndim := 1;
5200             else
5201                Ndim := UI_To_Int (Expr_Value (E1));
5202             end if;
5203
5204             Indx := First_Index (P_Type);
5205             for J in 1 .. Ndim - 1 loop
5206                Next_Index (Indx);
5207             end loop;
5208
5209             --  If no index type, get out (some other error occurred, and
5210             --  we don't have enough information to complete the job!)
5211
5212             if No (Indx) then
5213                Lo_Bound := Error;
5214                Hi_Bound := Error;
5215                return;
5216             end if;
5217
5218             Ityp := Etype (Indx);
5219          end if;
5220
5221          --  A discrete range in an index constraint is allowed to be a
5222          --  subtype indication. This is syntactically a pain, but should
5223          --  not propagate to the entity for the corresponding index subtype.
5224          --  After checking that the subtype indication is legal, the range
5225          --  of the subtype indication should be transfered to the entity.
5226          --  The attributes for the bounds should remain the simple retrievals
5227          --  that they are now.
5228
5229          Lo_Bound := Type_Low_Bound (Ityp);
5230          Hi_Bound := Type_High_Bound (Ityp);
5231
5232          if not Is_Static_Subtype (Ityp) then
5233             Static := False;
5234          end if;
5235       end Set_Bounds;
5236
5237       -------------------------------
5238       -- Statically_Denotes_Entity --
5239       -------------------------------
5240
5241       function Statically_Denotes_Entity (N : Node_Id) return Boolean is
5242          E : Entity_Id;
5243
5244       begin
5245          if not Is_Entity_Name (N) then
5246             return False;
5247          else
5248             E := Entity (N);
5249          end if;
5250
5251          return
5252            Nkind (Parent (E)) /= N_Object_Renaming_Declaration
5253              or else Statically_Denotes_Entity (Renamed_Object (E));
5254       end Statically_Denotes_Entity;
5255
5256    --  Start of processing for Eval_Attribute
5257
5258    begin
5259       --  Acquire first two expressions (at the moment, no attributes
5260       --  take more than two expressions in any case).
5261
5262       if Present (Expressions (N)) then
5263          E1 := First (Expressions (N));
5264          E2 := Next (E1);
5265       else
5266          E1 := Empty;
5267          E2 := Empty;
5268       end if;
5269
5270       --  Special processing for Enabled attribute. This attribute has a very
5271       --  special prefix, and the easiest way to avoid lots of special checks
5272       --  to protect this special prefix from causing trouble is to deal with
5273       --  this attribute immediately and be done with it.
5274
5275       if Id = Attribute_Enabled then
5276
5277          --  Evaluate the Enabled attribute
5278
5279          --  We skip evaluation if the expander is not active. This is not just
5280          --  an optimization. It is of key importance that we not rewrite the
5281          --  attribute in a generic template, since we want to pick up the
5282          --  setting of the check in the instance, and testing expander active
5283          --  is as easy way of doing this as any.
5284
5285          if Expander_Active then
5286             declare
5287                C : constant Check_Id := Get_Check_Id (Chars (P));
5288                R : Boolean;
5289
5290             begin
5291                if No (E1) then
5292                   if C in Predefined_Check_Id then
5293                      R := Scope_Suppress (C);
5294                   else
5295                      R := Is_Check_Suppressed (Empty, C);
5296                   end if;
5297
5298                else
5299                   R := Is_Check_Suppressed (Entity (E1), C);
5300                end if;
5301
5302                if R then
5303                   Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
5304                else
5305                   Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
5306                end if;
5307             end;
5308          end if;
5309
5310          return;
5311       end if;
5312
5313       --  Special processing for cases where the prefix is an object. For
5314       --  this purpose, a string literal counts as an object (attributes
5315       --  of string literals can only appear in generated code).
5316
5317       if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then
5318
5319          --  For Component_Size, the prefix is an array object, and we apply
5320          --  the attribute to the type of the object. This is allowed for
5321          --  both unconstrained and constrained arrays, since the bounds
5322          --  have no influence on the value of this attribute.
5323
5324          if Id = Attribute_Component_Size then
5325             P_Entity := Etype (P);
5326
5327          --  For First and Last, the prefix is an array object, and we apply
5328          --  the attribute to the type of the array, but we need a constrained
5329          --  type for this, so we use the actual subtype if available.
5330
5331          elsif Id = Attribute_First
5332                  or else
5333                Id = Attribute_Last
5334                  or else
5335                Id = Attribute_Length
5336          then
5337             declare
5338                AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P);
5339
5340             begin
5341                if Present (AS) and then Is_Constrained (AS) then
5342                   P_Entity := AS;
5343
5344                --  If we have an unconstrained type we cannot fold
5345
5346                else
5347                   Check_Expressions;
5348                   return;
5349                end if;
5350             end;
5351
5352          --  For Size, give size of object if available, otherwise we
5353          --  cannot fold Size.
5354
5355          elsif Id = Attribute_Size then
5356             if Is_Entity_Name (P)
5357               and then Known_Esize (Entity (P))
5358             then
5359                Compile_Time_Known_Attribute (N, Esize (Entity (P)));
5360                return;
5361
5362             else
5363                Check_Expressions;
5364                return;
5365             end if;
5366
5367          --  For Alignment, give size of object if available, otherwise we
5368          --  cannot fold Alignment.
5369
5370          elsif Id = Attribute_Alignment then
5371             if Is_Entity_Name (P)
5372               and then Known_Alignment (Entity (P))
5373             then
5374                Fold_Uint (N, Alignment (Entity (P)), False);
5375                return;
5376
5377             else
5378                Check_Expressions;
5379                return;
5380             end if;
5381
5382          --  No other attributes for objects are folded
5383
5384          else
5385             Check_Expressions;
5386             return;
5387          end if;
5388
5389       --  Cases where P is not an object. Cannot do anything if P is
5390       --  not the name of an entity.
5391
5392       elsif not Is_Entity_Name (P) then
5393          Check_Expressions;
5394          return;
5395
5396       --  Otherwise get prefix entity
5397
5398       else
5399          P_Entity := Entity (P);
5400       end if;
5401
5402       --  At this stage P_Entity is the entity to which the attribute
5403       --  is to be applied. This is usually simply the entity of the
5404       --  prefix, except in some cases of attributes for objects, where
5405       --  as described above, we apply the attribute to the object type.
5406
5407       --  First foldable possibility is a scalar or array type (RM 4.9(7))
5408       --  that is not generic (generic types are eliminated by RM 4.9(25)).
5409       --  Note we allow non-static non-generic types at this stage as further
5410       --  described below.
5411
5412       if Is_Type (P_Entity)
5413         and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity))
5414         and then (not Is_Generic_Type (P_Entity))
5415       then
5416          P_Type := P_Entity;
5417
5418       --  Second foldable possibility is an array object (RM 4.9(8))
5419
5420       elsif (Ekind (P_Entity) = E_Variable
5421                or else
5422              Ekind (P_Entity) = E_Constant)
5423         and then Is_Array_Type (Etype (P_Entity))
5424         and then (not Is_Generic_Type (Etype (P_Entity)))
5425       then
5426          P_Type := Etype (P_Entity);
5427
5428          --  If the entity is an array constant with an unconstrained nominal
5429          --  subtype then get the type from the initial value. If the value has
5430          --  been expanded into assignments, there is no expression and the
5431          --  attribute reference remains dynamic.
5432
5433          --  We could do better here and retrieve the type ???
5434
5435          if Ekind (P_Entity) = E_Constant
5436            and then not Is_Constrained (P_Type)
5437          then
5438             if No (Constant_Value (P_Entity)) then
5439                return;
5440             else
5441                P_Type := Etype (Constant_Value (P_Entity));
5442             end if;
5443          end if;
5444
5445       --  Definite must be folded if the prefix is not a generic type,
5446       --  that is to say if we are within an instantiation. Same processing
5447       --  applies to the GNAT attributes Has_Discriminants, Type_Class,
5448       --  Has_Tagged_Value, and Unconstrained_Array.
5449
5450       elsif (Id = Attribute_Definite
5451                or else
5452              Id = Attribute_Has_Access_Values
5453                or else
5454              Id = Attribute_Has_Discriminants
5455                or else
5456              Id = Attribute_Has_Tagged_Values
5457                or else
5458              Id = Attribute_Type_Class
5459                or else
5460              Id = Attribute_Unconstrained_Array)
5461         and then not Is_Generic_Type (P_Entity)
5462       then
5463          P_Type := P_Entity;
5464
5465       --  We can fold 'Size applied to a type if the size is known (as happens
5466       --  for a size from an attribute definition clause). At this stage, this
5467       --  can happen only for types (e.g. record types) for which the size is
5468       --  always non-static. We exclude generic types from consideration (since
5469       --  they have bogus sizes set within templates).
5470
5471       elsif Id = Attribute_Size
5472         and then Is_Type (P_Entity)
5473         and then (not Is_Generic_Type (P_Entity))
5474         and then Known_Static_RM_Size (P_Entity)
5475       then
5476          Compile_Time_Known_Attribute (N, RM_Size (P_Entity));
5477          return;
5478
5479       --  We can fold 'Alignment applied to a type if the alignment is known
5480       --  (as happens for an alignment from an attribute definition clause).
5481       --  At this stage, this can happen only for types (e.g. record
5482       --  types) for which the size is always non-static. We exclude
5483       --  generic types from consideration (since they have bogus
5484       --  sizes set within templates).
5485
5486       elsif Id = Attribute_Alignment
5487         and then Is_Type (P_Entity)
5488         and then (not Is_Generic_Type (P_Entity))
5489         and then Known_Alignment (P_Entity)
5490       then
5491          Compile_Time_Known_Attribute (N, Alignment (P_Entity));
5492          return;
5493
5494       --  If this is an access attribute that is known to fail accessibility
5495       --  check, rewrite accordingly.
5496
5497       elsif Attribute_Name (N) = Name_Access
5498         and then Raises_Constraint_Error (N)
5499       then
5500          Rewrite (N,
5501            Make_Raise_Program_Error (Loc,
5502              Reason => PE_Accessibility_Check_Failed));
5503          Set_Etype (N, C_Type);
5504          return;
5505
5506       --  No other cases are foldable (they certainly aren't static, and at
5507       --  the moment we don't try to fold any cases other than these three).
5508
5509       else
5510          Check_Expressions;
5511          return;
5512       end if;
5513
5514       --  If either attribute or the prefix is Any_Type, then propagate
5515       --  Any_Type to the result and don't do anything else at all.
5516
5517       if P_Type = Any_Type
5518         or else (Present (E1) and then Etype (E1) = Any_Type)
5519         or else (Present (E2) and then Etype (E2) = Any_Type)
5520       then
5521          Set_Etype (N, Any_Type);
5522          return;
5523       end if;
5524
5525       --  Scalar subtype case. We have not yet enforced the static requirement
5526       --  of (RM 4.9(7)) and we don't intend to just yet, since there are cases
5527       --  of non-static attribute references (e.g. S'Digits for a non-static
5528       --  floating-point type, which we can compute at compile time).
5529
5530       --  Note: this folding of non-static attributes is not simply a case of
5531       --  optimization. For many of the attributes affected, Gigi cannot handle
5532       --  the attribute and depends on the front end having folded them away.
5533
5534       --  Note: although we don't require staticness at this stage, we do set
5535       --  the Static variable to record the staticness, for easy reference by
5536       --  those attributes where it matters (e.g. Succ and Pred), and also to
5537       --  be used to ensure that non-static folded things are not marked as
5538       --  being static (a check that is done right at the end).
5539
5540       P_Root_Type := Root_Type (P_Type);
5541       P_Base_Type := Base_Type (P_Type);
5542
5543       --  If the root type or base type is generic, then we cannot fold. This
5544       --  test is needed because subtypes of generic types are not always
5545       --  marked as being generic themselves (which seems odd???)
5546
5547       if Is_Generic_Type (P_Root_Type)
5548         or else Is_Generic_Type (P_Base_Type)
5549       then
5550          return;
5551       end if;
5552
5553       if Is_Scalar_Type (P_Type) then
5554          Static := Is_OK_Static_Subtype (P_Type);
5555
5556       --  Array case. We enforce the constrained requirement of (RM 4.9(7-8))
5557       --  since we can't do anything with unconstrained arrays. In addition,
5558       --  only the First, Last and Length attributes are possibly static.
5559
5560       --  Definite, Has_Access_Values, Has_Discriminants, Has_Tagged_Values,
5561       --  Type_Class, and Unconstrained_Array are again exceptions, because
5562       --  they apply as well to unconstrained types.
5563
5564       --  In addition Component_Size is an exception since it is possibly
5565       --  foldable, even though it is never static, and it does apply to
5566       --  unconstrained arrays. Furthermore, it is essential to fold this
5567       --  in the packed case, since otherwise the value will be incorrect.
5568
5569       elsif Id = Attribute_Definite
5570               or else
5571             Id = Attribute_Has_Access_Values
5572               or else
5573             Id = Attribute_Has_Discriminants
5574               or else
5575             Id = Attribute_Has_Tagged_Values
5576               or else
5577             Id = Attribute_Type_Class
5578               or else
5579             Id = Attribute_Unconstrained_Array
5580               or else
5581             Id = Attribute_Component_Size
5582       then
5583          Static := False;
5584
5585       else
5586          if not Is_Constrained (P_Type)
5587            or else (Id /= Attribute_First and then
5588                     Id /= Attribute_Last  and then
5589                     Id /= Attribute_Length)
5590          then
5591             Check_Expressions;
5592             return;
5593          end if;
5594
5595          --  The rules in (RM 4.9(7,8)) require a static array, but as in the
5596          --  scalar case, we hold off on enforcing staticness, since there are
5597          --  cases which we can fold at compile time even though they are not
5598          --  static (e.g. 'Length applied to a static index, even though other
5599          --  non-static indexes make the array type non-static). This is only
5600          --  an optimization, but it falls out essentially free, so why not.
5601          --  Again we compute the variable Static for easy reference later
5602          --  (note that no array attributes are static in Ada 83).
5603
5604          --  We also need to set Static properly for subsequent legality checks
5605          --  which might otherwise accept non-static constants in contexts
5606          --  where they are not legal.
5607
5608          Static := Ada_Version >= Ada_95
5609                      and then Statically_Denotes_Entity (P);
5610
5611          declare
5612             N : Node_Id;
5613
5614          begin
5615             N := First_Index (P_Type);
5616
5617             --  The expression is static if the array type is constrained
5618             --  by given bounds, and not by an initial expression. Constant
5619             --  strings are static in any case.
5620
5621             if Root_Type (P_Type) /= Standard_String then
5622                Static :=
5623                  Static and then not Is_Constr_Subt_For_U_Nominal (P_Type);
5624             end if;
5625
5626             while Present (N) loop
5627                Static := Static and then Is_Static_Subtype (Etype (N));
5628
5629                --  If however the index type is generic, attributes cannot
5630                --  be folded.
5631
5632                if Is_Generic_Type (Etype (N))
5633                  and then Id /= Attribute_Component_Size
5634                then
5635                   return;
5636                end if;
5637
5638                Next_Index (N);
5639             end loop;
5640          end;
5641       end if;
5642
5643       --  Check any expressions that are present. Note that these expressions,
5644       --  depending on the particular attribute type, are either part of the
5645       --  attribute designator, or they are arguments in a case where the
5646       --  attribute reference returns a function. In the latter case, the
5647       --  rule in (RM 4.9(22)) applies and in particular requires the type
5648       --  of the expressions to be scalar in order for the attribute to be
5649       --  considered to be static.
5650
5651       declare
5652          E : Node_Id;
5653
5654       begin
5655          E := E1;
5656          while Present (E) loop
5657
5658             --  If expression is not static, then the attribute reference
5659             --  result certainly cannot be static.
5660
5661             if not Is_Static_Expression (E) then
5662                Static := False;
5663             end if;
5664
5665             --  If the result is not known at compile time, or is not of
5666             --  a scalar type, then the result is definitely not static,
5667             --  so we can quit now.
5668
5669             if not Compile_Time_Known_Value (E)
5670               or else not Is_Scalar_Type (Etype (E))
5671             then
5672                --  An odd special case, if this is a Pos attribute, this
5673                --  is where we need to apply a range check since it does
5674                --  not get done anywhere else.
5675
5676                if Id = Attribute_Pos then
5677                   if Is_Integer_Type (Etype (E)) then
5678                      Apply_Range_Check (E, Etype (N));
5679                   end if;
5680                end if;
5681
5682                Check_Expressions;
5683                return;
5684
5685             --  If the expression raises a constraint error, then so does
5686             --  the attribute reference. We keep going in this case because
5687             --  we are still interested in whether the attribute reference
5688             --  is static even if it is not static.
5689
5690             elsif Raises_Constraint_Error (E) then
5691                Set_Raises_Constraint_Error (N);
5692             end if;
5693
5694             Next (E);
5695          end loop;
5696
5697          if Raises_Constraint_Error (Prefix (N)) then
5698             return;
5699          end if;
5700       end;
5701
5702       --  Deal with the case of a static attribute reference that raises
5703       --  constraint error. The Raises_Constraint_Error flag will already
5704       --  have been set, and the Static flag shows whether the attribute
5705       --  reference is static. In any case we certainly can't fold such an
5706       --  attribute reference.
5707
5708       --  Note that the rewriting of the attribute node with the constraint
5709       --  error node is essential in this case, because otherwise Gigi might
5710       --  blow up on one of the attributes it never expects to see.
5711
5712       --  The constraint_error node must have the type imposed by the context,
5713       --  to avoid spurious errors in the enclosing expression.
5714
5715       if Raises_Constraint_Error (N) then
5716          CE_Node :=
5717            Make_Raise_Constraint_Error (Sloc (N),
5718              Reason => CE_Range_Check_Failed);
5719          Set_Etype (CE_Node, Etype (N));
5720          Set_Raises_Constraint_Error (CE_Node);
5721          Check_Expressions;
5722          Rewrite (N, Relocate_Node (CE_Node));
5723          Set_Is_Static_Expression (N, Static);
5724          return;
5725       end if;
5726
5727       --  At this point we have a potentially foldable attribute reference.
5728       --  If Static is set, then the attribute reference definitely obeys
5729       --  the requirements in (RM 4.9(7,8,22)), and it definitely can be
5730       --  folded. If Static is not set, then the attribute may or may not
5731       --  be foldable, and the individual attribute processing routines
5732       --  test Static as required in cases where it makes a difference.
5733
5734       --  In the case where Static is not set, we do know that all the
5735       --  expressions present are at least known at compile time (we
5736       --  assumed above that if this was not the case, then there was
5737       --  no hope of static evaluation). However, we did not require
5738       --  that the bounds of the prefix type be compile time known,
5739       --  let alone static). That's because there are many attributes
5740       --  that can be computed at compile time on non-static subtypes,
5741       --  even though such references are not static expressions.
5742
5743       case Id is
5744
5745       --------------
5746       -- Adjacent --
5747       --------------
5748
5749       when Attribute_Adjacent =>
5750          Fold_Ureal (N,
5751            Eval_Fat.Adjacent
5752              (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
5753
5754       ---------
5755       -- Aft --
5756       ---------
5757
5758       when Attribute_Aft =>
5759          Fold_Uint (N, UI_From_Int (Aft_Value), True);
5760
5761       ---------------
5762       -- Alignment --
5763       ---------------
5764
5765       when Attribute_Alignment => Alignment_Block : declare
5766          P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
5767
5768       begin
5769          --  Fold if alignment is set and not otherwise
5770
5771          if Known_Alignment (P_TypeA) then
5772             Fold_Uint (N, Alignment (P_TypeA), Is_Discrete_Type (P_TypeA));
5773          end if;
5774       end Alignment_Block;
5775
5776       ---------------
5777       -- AST_Entry --
5778       ---------------
5779
5780       --  Can only be folded in No_Ast_Handler case
5781
5782       when Attribute_AST_Entry =>
5783          if not Is_AST_Entry (P_Entity) then
5784             Rewrite (N,
5785               New_Occurrence_Of (RTE (RE_No_AST_Handler), Loc));
5786          else
5787             null;
5788          end if;
5789
5790       ---------
5791       -- Bit --
5792       ---------
5793
5794       --  Bit can never be folded
5795
5796       when Attribute_Bit =>
5797          null;
5798
5799       ------------------
5800       -- Body_Version --
5801       ------------------
5802
5803       --  Body_version can never be static
5804
5805       when Attribute_Body_Version =>
5806          null;
5807
5808       -------------
5809       -- Ceiling --
5810       -------------
5811
5812       when Attribute_Ceiling =>
5813          Fold_Ureal (N,
5814            Eval_Fat.Ceiling (P_Root_Type, Expr_Value_R (E1)), Static);
5815
5816       --------------------
5817       -- Component_Size --
5818       --------------------
5819
5820       when Attribute_Component_Size =>
5821          if Known_Static_Component_Size (P_Type) then
5822             Fold_Uint (N, Component_Size (P_Type), False);
5823          end if;
5824
5825       -------------
5826       -- Compose --
5827       -------------
5828
5829       when Attribute_Compose =>
5830          Fold_Ureal (N,
5831            Eval_Fat.Compose
5832              (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)),
5833               Static);
5834
5835       -----------------
5836       -- Constrained --
5837       -----------------
5838
5839       --  Constrained is never folded for now, there may be cases that
5840       --  could be handled at compile time. To be looked at later.
5841
5842       when Attribute_Constrained =>
5843          null;
5844
5845       ---------------
5846       -- Copy_Sign --
5847       ---------------
5848
5849       when Attribute_Copy_Sign =>
5850          Fold_Ureal (N,
5851            Eval_Fat.Copy_Sign
5852              (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
5853
5854       -----------
5855       -- Delta --
5856       -----------
5857
5858       when Attribute_Delta =>
5859          Fold_Ureal (N, Delta_Value (P_Type), True);
5860
5861       --------------
5862       -- Definite --
5863       --------------
5864
5865       when Attribute_Definite =>
5866          Rewrite (N, New_Occurrence_Of (
5867            Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc));
5868          Analyze_And_Resolve (N, Standard_Boolean);
5869
5870       ------------
5871       -- Denorm --
5872       ------------
5873
5874       when Attribute_Denorm =>
5875          Fold_Uint
5876            (N, UI_From_Int (Boolean'Pos (Denorm_On_Target)), True);
5877
5878       ------------
5879       -- Digits --
5880       ------------
5881
5882       when Attribute_Digits =>
5883          Fold_Uint (N, Digits_Value (P_Type), True);
5884
5885       ----------
5886       -- Emax --
5887       ----------
5888
5889       when Attribute_Emax =>
5890
5891          --  Ada 83 attribute is defined as (RM83 3.5.8)
5892
5893          --    T'Emax = 4 * T'Mantissa
5894
5895          Fold_Uint (N, 4 * Mantissa, True);
5896
5897       --------------
5898       -- Enum_Rep --
5899       --------------
5900
5901       when Attribute_Enum_Rep =>
5902
5903          --  For an enumeration type with a non-standard representation use
5904          --  the Enumeration_Rep field of the proper constant. Note that this
5905          --  will not work for types Character/Wide_[Wide-]Character, since no
5906          --  real entities are created for the enumeration literals, but that
5907          --  does not matter since these two types do not have non-standard
5908          --  representations anyway.
5909
5910          if Is_Enumeration_Type (P_Type)
5911            and then Has_Non_Standard_Rep (P_Type)
5912          then
5913             Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)), Static);
5914
5915          --  For enumeration types with standard representations and all
5916          --  other cases (i.e. all integer and modular types), Enum_Rep
5917          --  is equivalent to Pos.
5918
5919          else
5920             Fold_Uint (N, Expr_Value (E1), Static);
5921          end if;
5922
5923       --------------
5924       -- Enum_Val --
5925       --------------
5926
5927       when Attribute_Enum_Val => Enum_Val : declare
5928          Lit : Node_Id;
5929
5930       begin
5931          --  We have something like Enum_Type'Enum_Val (23), so search for a
5932          --  corresponding value in the list of Enum_Rep values for the type.
5933
5934          Lit := First_Literal (P_Base_Type);
5935          loop
5936             if Enumeration_Rep (Lit) = Expr_Value (E1) then
5937                Fold_Uint (N, Enumeration_Pos (Lit), Static);
5938                exit;
5939             end if;
5940
5941             Next_Literal (Lit);
5942
5943             if No (Lit) then
5944                Apply_Compile_Time_Constraint_Error
5945                  (N, "no representation value matches",
5946                   CE_Range_Check_Failed,
5947                   Warn => not Static);
5948                exit;
5949             end if;
5950          end loop;
5951       end Enum_Val;
5952
5953       -------------
5954       -- Epsilon --
5955       -------------
5956
5957       when Attribute_Epsilon =>
5958
5959          --  Ada 83 attribute is defined as (RM83 3.5.8)
5960
5961          --    T'Epsilon = 2.0**(1 - T'Mantissa)
5962
5963          Fold_Ureal (N, Ureal_2 ** (1 - Mantissa), True);
5964
5965       --------------
5966       -- Exponent --
5967       --------------
5968
5969       when Attribute_Exponent =>
5970          Fold_Uint (N,
5971            Eval_Fat.Exponent (P_Root_Type, Expr_Value_R (E1)), Static);
5972
5973       -----------
5974       -- First --
5975       -----------
5976
5977       when Attribute_First => First_Attr :
5978       begin
5979          Set_Bounds;
5980
5981          if Compile_Time_Known_Value (Lo_Bound) then
5982             if Is_Real_Type (P_Type) then
5983                Fold_Ureal (N, Expr_Value_R (Lo_Bound), Static);
5984             else
5985                Fold_Uint  (N, Expr_Value (Lo_Bound), Static);
5986             end if;
5987          end if;
5988       end First_Attr;
5989
5990       -----------------
5991       -- Fixed_Value --
5992       -----------------
5993
5994       when Attribute_Fixed_Value =>
5995          null;
5996
5997       -----------
5998       -- Floor --
5999       -----------
6000
6001       when Attribute_Floor =>
6002          Fold_Ureal (N,
6003            Eval_Fat.Floor (P_Root_Type, Expr_Value_R (E1)), Static);
6004
6005       ----------
6006       -- Fore --
6007       ----------
6008
6009       when Attribute_Fore =>
6010          if Compile_Time_Known_Bounds (P_Type) then
6011             Fold_Uint (N, UI_From_Int (Fore_Value), Static);
6012          end if;
6013
6014       --------------
6015       -- Fraction --
6016       --------------
6017
6018       when Attribute_Fraction =>
6019          Fold_Ureal (N,
6020            Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1)), Static);
6021
6022       -----------------------
6023       -- Has_Access_Values --
6024       -----------------------
6025
6026       when Attribute_Has_Access_Values =>
6027          Rewrite (N, New_Occurrence_Of
6028            (Boolean_Literals (Has_Access_Values (P_Root_Type)), Loc));
6029          Analyze_And_Resolve (N, Standard_Boolean);
6030
6031       -----------------------
6032       -- Has_Discriminants --
6033       -----------------------
6034
6035       when Attribute_Has_Discriminants =>
6036          Rewrite (N, New_Occurrence_Of (
6037            Boolean_Literals (Has_Discriminants (P_Entity)), Loc));
6038          Analyze_And_Resolve (N, Standard_Boolean);
6039
6040       -----------------------
6041       -- Has_Tagged_Values --
6042       -----------------------
6043
6044       when Attribute_Has_Tagged_Values =>
6045          Rewrite (N, New_Occurrence_Of
6046            (Boolean_Literals (Has_Tagged_Component (P_Root_Type)), Loc));
6047          Analyze_And_Resolve (N, Standard_Boolean);
6048
6049       --------------
6050       -- Identity --
6051       --------------
6052
6053       when Attribute_Identity =>
6054          null;
6055
6056       -----------
6057       -- Image --
6058       -----------
6059
6060       --  Image is a scalar attribute, but is never static, because it is
6061       --  not a static function (having a non-scalar argument (RM 4.9(22))
6062       --  However, we can constant-fold the image of an enumeration literal
6063       --  if names are available.
6064
6065       when Attribute_Image =>
6066          if Is_Entity_Name (E1)
6067            and then Ekind (Entity (E1)) = E_Enumeration_Literal
6068            and then not Discard_Names (First_Subtype (Etype (E1)))
6069            and then not Global_Discard_Names
6070          then
6071             declare
6072                Lit : constant Entity_Id := Entity (E1);
6073                Str : String_Id;
6074             begin
6075                Start_String;
6076                Get_Unqualified_Decoded_Name_String (Chars (Lit));
6077                Set_Casing (All_Upper_Case);
6078                Store_String_Chars (Name_Buffer (1 .. Name_Len));
6079                Str := End_String;
6080                Rewrite (N, Make_String_Literal (Loc, Strval => Str));
6081                Analyze_And_Resolve (N, Standard_String);
6082                Set_Is_Static_Expression (N, False);
6083             end;
6084          end if;
6085
6086       ---------
6087       -- Img --
6088       ---------
6089
6090       --  Img is a scalar attribute, but is never static, because it is
6091       --  not a static function (having a non-scalar argument (RM 4.9(22))
6092
6093       when Attribute_Img =>
6094          null;
6095
6096       -------------------
6097       -- Integer_Value --
6098       -------------------
6099
6100       --  We never try to fold Integer_Value (though perhaps we could???)
6101
6102       when Attribute_Integer_Value =>
6103          null;
6104
6105       -------------------
6106       -- Invalid_Value --
6107       -------------------
6108
6109       --  Invalid_Value is a scalar attribute that is never static, because
6110       --  the value is by design out of range.
6111
6112       when Attribute_Invalid_Value =>
6113          null;
6114
6115       -----------
6116       -- Large --
6117       -----------
6118
6119       when Attribute_Large =>
6120
6121          --  For fixed-point, we use the identity:
6122
6123          --    T'Large = (2.0**T'Mantissa - 1.0) * T'Small
6124
6125          if Is_Fixed_Point_Type (P_Type) then
6126             Rewrite (N,
6127               Make_Op_Multiply (Loc,
6128                 Left_Opnd =>
6129                   Make_Op_Subtract (Loc,
6130                     Left_Opnd =>
6131                       Make_Op_Expon (Loc,
6132                         Left_Opnd =>
6133                           Make_Real_Literal (Loc, Ureal_2),
6134                         Right_Opnd =>
6135                           Make_Attribute_Reference (Loc,
6136                             Prefix => P,
6137                             Attribute_Name => Name_Mantissa)),
6138                     Right_Opnd => Make_Real_Literal (Loc, Ureal_1)),
6139
6140                 Right_Opnd =>
6141                   Make_Real_Literal (Loc, Small_Value (Entity (P)))));
6142
6143             Analyze_And_Resolve (N, C_Type);
6144
6145          --  Floating-point (Ada 83 compatibility)
6146
6147          else
6148             --  Ada 83 attribute is defined as (RM83 3.5.8)
6149
6150             --    T'Large = 2.0**T'Emax * (1.0 - 2.0**(-T'Mantissa))
6151
6152             --  where
6153
6154             --    T'Emax = 4 * T'Mantissa
6155
6156             Fold_Ureal (N,
6157               Ureal_2 ** (4 * Mantissa) * (Ureal_1 - Ureal_2 ** (-Mantissa)),
6158               True);
6159          end if;
6160
6161       ----------
6162       -- Last --
6163       ----------
6164
6165       when Attribute_Last => Last :
6166       begin
6167          Set_Bounds;
6168
6169          if Compile_Time_Known_Value (Hi_Bound) then
6170             if Is_Real_Type (P_Type) then
6171                Fold_Ureal (N, Expr_Value_R (Hi_Bound), Static);
6172             else
6173                Fold_Uint  (N, Expr_Value (Hi_Bound), Static);
6174             end if;
6175          end if;
6176       end Last;
6177
6178       ------------------
6179       -- Leading_Part --
6180       ------------------
6181
6182       when Attribute_Leading_Part =>
6183          Fold_Ureal (N,
6184            Eval_Fat.Leading_Part
6185              (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static);
6186
6187       ------------
6188       -- Length --
6189       ------------
6190
6191       when Attribute_Length => Length : declare
6192          Ind : Node_Id;
6193
6194       begin
6195          --  In the case of a generic index type, the bounds may appear static
6196          --  but the computation is not meaningful in this case, and may
6197          --  generate a spurious warning.
6198
6199          Ind := First_Index (P_Type);
6200          while Present (Ind) loop
6201             if Is_Generic_Type (Etype (Ind)) then
6202                return;
6203             end if;
6204
6205             Next_Index (Ind);
6206          end loop;
6207
6208          Set_Bounds;
6209
6210          --  For two compile time values, we can compute length
6211
6212          if Compile_Time_Known_Value (Lo_Bound)
6213            and then Compile_Time_Known_Value (Hi_Bound)
6214          then
6215             Fold_Uint (N,
6216               UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))),
6217               True);
6218          end if;
6219
6220          --  One more case is where Hi_Bound and Lo_Bound are compile-time
6221          --  comparable, and we can figure out the difference between them.
6222
6223          declare
6224             Diff : aliased Uint;
6225
6226          begin
6227             case
6228               Compile_Time_Compare
6229                 (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
6230             is
6231                when EQ =>
6232                   Fold_Uint (N, Uint_1, False);
6233
6234                when GT =>
6235                   Fold_Uint (N, Uint_0, False);
6236
6237                when LT =>
6238                   if Diff /= No_Uint then
6239                      Fold_Uint (N, Diff + 1, False);
6240                   end if;
6241
6242                when others =>
6243                   null;
6244             end case;
6245          end;
6246       end Length;
6247
6248       -------------
6249       -- Machine --
6250       -------------
6251
6252       when Attribute_Machine =>
6253          Fold_Ureal (N,
6254            Eval_Fat.Machine
6255              (P_Root_Type, Expr_Value_R (E1), Eval_Fat.Round, N),
6256            Static);
6257
6258       ------------------
6259       -- Machine_Emax --
6260       ------------------
6261
6262       when Attribute_Machine_Emax =>
6263          Float_Attribute_Universal_Integer (
6264            IEEES_Machine_Emax,
6265            IEEEL_Machine_Emax,
6266            IEEEX_Machine_Emax,
6267            VAXFF_Machine_Emax,
6268            VAXDF_Machine_Emax,
6269            VAXGF_Machine_Emax,
6270            AAMPS_Machine_Emax,
6271            AAMPL_Machine_Emax);
6272
6273       ------------------
6274       -- Machine_Emin --
6275       ------------------
6276
6277       when Attribute_Machine_Emin =>
6278          Float_Attribute_Universal_Integer (
6279            IEEES_Machine_Emin,
6280            IEEEL_Machine_Emin,
6281            IEEEX_Machine_Emin,
6282            VAXFF_Machine_Emin,
6283            VAXDF_Machine_Emin,
6284            VAXGF_Machine_Emin,
6285            AAMPS_Machine_Emin,
6286            AAMPL_Machine_Emin);
6287
6288       ----------------------
6289       -- Machine_Mantissa --
6290       ----------------------
6291
6292       when Attribute_Machine_Mantissa =>
6293          Float_Attribute_Universal_Integer (
6294            IEEES_Machine_Mantissa,
6295            IEEEL_Machine_Mantissa,
6296            IEEEX_Machine_Mantissa,
6297            VAXFF_Machine_Mantissa,
6298            VAXDF_Machine_Mantissa,
6299            VAXGF_Machine_Mantissa,
6300            AAMPS_Machine_Mantissa,
6301            AAMPL_Machine_Mantissa);
6302
6303       -----------------------
6304       -- Machine_Overflows --
6305       -----------------------
6306
6307       when Attribute_Machine_Overflows =>
6308
6309          --  Always true for fixed-point
6310
6311          if Is_Fixed_Point_Type (P_Type) then
6312             Fold_Uint (N, True_Value, True);
6313
6314          --  Floating point case
6315
6316          else
6317             Fold_Uint (N,
6318               UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)),
6319               True);
6320          end if;
6321
6322       -------------------
6323       -- Machine_Radix --
6324       -------------------
6325
6326       when Attribute_Machine_Radix =>
6327          if Is_Fixed_Point_Type (P_Type) then
6328             if Is_Decimal_Fixed_Point_Type (P_Type)
6329               and then Machine_Radix_10 (P_Type)
6330             then
6331                Fold_Uint (N, Uint_10, True);
6332             else
6333                Fold_Uint (N, Uint_2, True);
6334             end if;
6335
6336          --  All floating-point type always have radix 2
6337
6338          else
6339             Fold_Uint (N, Uint_2, True);
6340          end if;
6341
6342       ----------------------
6343       -- Machine_Rounding --
6344       ----------------------
6345
6346       --  Note: for the folding case, it is fine to treat Machine_Rounding
6347       --  exactly the same way as Rounding, since this is one of the allowed
6348       --  behaviors, and performance is not an issue here. It might be a bit
6349       --  better to give the same result as it would give at run-time, even
6350       --  though the non-determinism is certainly permitted.
6351
6352       when Attribute_Machine_Rounding =>
6353          Fold_Ureal (N,
6354            Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static);
6355
6356       --------------------
6357       -- Machine_Rounds --
6358       --------------------
6359
6360       when Attribute_Machine_Rounds =>
6361
6362          --  Always False for fixed-point
6363
6364          if Is_Fixed_Point_Type (P_Type) then
6365             Fold_Uint (N, False_Value, True);
6366
6367          --  Else yield proper floating-point result
6368
6369          else
6370             Fold_Uint
6371               (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)), True);
6372          end if;
6373
6374       ------------------
6375       -- Machine_Size --
6376       ------------------
6377
6378       --  Note: Machine_Size is identical to Object_Size
6379
6380       when Attribute_Machine_Size => Machine_Size : declare
6381          P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
6382
6383       begin
6384          if Known_Esize (P_TypeA) then
6385             Fold_Uint (N, Esize (P_TypeA), True);
6386          end if;
6387       end Machine_Size;
6388
6389       --------------
6390       -- Mantissa --
6391       --------------
6392
6393       when Attribute_Mantissa =>
6394
6395          --  Fixed-point mantissa
6396
6397          if Is_Fixed_Point_Type (P_Type) then
6398
6399             --  Compile time foldable case
6400
6401             if Compile_Time_Known_Value (Type_Low_Bound  (P_Type))
6402                  and then
6403                Compile_Time_Known_Value (Type_High_Bound (P_Type))
6404             then
6405                --  The calculation of the obsolete Ada 83 attribute Mantissa
6406                --  is annoying, because of AI00143, quoted here:
6407
6408                --  !question 84-01-10
6409
6410                --  Consider the model numbers for F:
6411
6412                --         type F is delta 1.0 range -7.0 .. 8.0;
6413
6414                --  The wording requires that F'MANTISSA be the SMALLEST
6415                --  integer number for which each  bound  of the specified
6416                --  range is either a model number or lies at most small
6417                --  distant from a model number. This means F'MANTISSA
6418                --  is required to be 3 since the range  -7.0 .. 7.0 fits
6419                --  in 3 signed bits, and 8 is "at most" 1.0 from a model
6420                --  number, namely, 7. Is this analysis correct? Note that
6421                --  this implies the upper bound of the range is not
6422                --  represented as a model number.
6423
6424                --  !response 84-03-17
6425
6426                --  The analysis is correct. The upper and lower bounds for
6427                --  a fixed  point type can lie outside the range of model
6428                --  numbers.
6429
6430                declare
6431                   Siz     : Uint;
6432                   LBound  : Ureal;
6433                   UBound  : Ureal;
6434                   Bound   : Ureal;
6435                   Max_Man : Uint;
6436
6437                begin
6438                   LBound  := Expr_Value_R (Type_Low_Bound  (P_Type));
6439                   UBound  := Expr_Value_R (Type_High_Bound (P_Type));
6440                   Bound   := UR_Max (UR_Abs (LBound), UR_Abs (UBound));
6441                   Max_Man := UR_Trunc (Bound / Small_Value (P_Type));
6442
6443                   --  If the Bound is exactly a model number, i.e. a multiple
6444                   --  of Small, then we back it off by one to get the integer
6445                   --  value that must be representable.
6446
6447                   if Small_Value (P_Type) * Max_Man = Bound then
6448                      Max_Man := Max_Man - 1;
6449                   end if;
6450
6451                   --  Now find corresponding size = Mantissa value
6452
6453                   Siz := Uint_0;
6454                   while 2 ** Siz < Max_Man loop
6455                      Siz := Siz + 1;
6456                   end loop;
6457
6458                   Fold_Uint (N, Siz, True);
6459                end;
6460
6461             else
6462                --  The case of dynamic bounds cannot be evaluated at compile
6463                --  time. Instead we use a runtime routine (see Exp_Attr).
6464
6465                null;
6466             end if;
6467
6468          --  Floating-point Mantissa
6469
6470          else
6471             Fold_Uint (N, Mantissa, True);
6472          end if;
6473
6474       ---------
6475       -- Max --
6476       ---------
6477
6478       when Attribute_Max => Max :
6479       begin
6480          if Is_Real_Type (P_Type) then
6481             Fold_Ureal
6482               (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
6483          else
6484             Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static);
6485          end if;
6486       end Max;
6487
6488       ----------------------------------
6489       -- Max_Size_In_Storage_Elements --
6490       ----------------------------------
6491
6492       --  Max_Size_In_Storage_Elements is simply the Size rounded up to a
6493       --  Storage_Unit boundary. We can fold any cases for which the size
6494       --  is known by the front end.
6495
6496       when Attribute_Max_Size_In_Storage_Elements =>
6497          if Known_Esize (P_Type) then
6498             Fold_Uint (N,
6499               (Esize (P_Type) + System_Storage_Unit - 1) /
6500                                           System_Storage_Unit,
6501                Static);
6502          end if;
6503
6504       --------------------
6505       -- Mechanism_Code --
6506       --------------------
6507
6508       when Attribute_Mechanism_Code =>
6509          declare
6510             Val    : Int;
6511             Formal : Entity_Id;
6512             Mech   : Mechanism_Type;
6513
6514          begin
6515             if No (E1) then
6516                Mech := Mechanism (P_Entity);
6517
6518             else
6519                Val := UI_To_Int (Expr_Value (E1));
6520
6521                Formal := First_Formal (P_Entity);
6522                for J in 1 .. Val - 1 loop
6523                   Next_Formal (Formal);
6524                end loop;
6525                Mech := Mechanism (Formal);
6526             end if;
6527
6528             if Mech < 0 then
6529                Fold_Uint (N, UI_From_Int (Int (-Mech)), True);
6530             end if;
6531          end;
6532
6533       ---------
6534       -- Min --
6535       ---------
6536
6537       when Attribute_Min => Min :
6538       begin
6539          if Is_Real_Type (P_Type) then
6540             Fold_Ureal
6541               (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
6542          else
6543             Fold_Uint
6544               (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static);
6545          end if;
6546       end Min;
6547
6548       ---------
6549       -- Mod --
6550       ---------
6551
6552       when Attribute_Mod =>
6553          Fold_Uint
6554            (N, UI_Mod (Expr_Value (E1), Modulus (P_Base_Type)), Static);
6555
6556       -----------
6557       -- Model --
6558       -----------
6559
6560       when Attribute_Model =>
6561          Fold_Ureal (N,
6562            Eval_Fat.Model (P_Root_Type, Expr_Value_R (E1)), Static);
6563
6564       ----------------
6565       -- Model_Emin --
6566       ----------------
6567
6568       when Attribute_Model_Emin =>
6569          Float_Attribute_Universal_Integer (
6570            IEEES_Model_Emin,
6571            IEEEL_Model_Emin,
6572            IEEEX_Model_Emin,
6573            VAXFF_Model_Emin,
6574            VAXDF_Model_Emin,
6575            VAXGF_Model_Emin,
6576            AAMPS_Model_Emin,
6577            AAMPL_Model_Emin);
6578
6579       -------------------
6580       -- Model_Epsilon --
6581       -------------------
6582
6583       when Attribute_Model_Epsilon =>
6584          Float_Attribute_Universal_Real (
6585            IEEES_Model_Epsilon'Universal_Literal_String,
6586            IEEEL_Model_Epsilon'Universal_Literal_String,
6587            IEEEX_Model_Epsilon'Universal_Literal_String,
6588            VAXFF_Model_Epsilon'Universal_Literal_String,
6589            VAXDF_Model_Epsilon'Universal_Literal_String,
6590            VAXGF_Model_Epsilon'Universal_Literal_String,
6591            AAMPS_Model_Epsilon'Universal_Literal_String,
6592            AAMPL_Model_Epsilon'Universal_Literal_String);
6593
6594       --------------------
6595       -- Model_Mantissa --
6596       --------------------
6597
6598       when Attribute_Model_Mantissa =>
6599          Float_Attribute_Universal_Integer (
6600            IEEES_Model_Mantissa,
6601            IEEEL_Model_Mantissa,
6602            IEEEX_Model_Mantissa,
6603            VAXFF_Model_Mantissa,
6604            VAXDF_Model_Mantissa,
6605            VAXGF_Model_Mantissa,
6606            AAMPS_Model_Mantissa,
6607            AAMPL_Model_Mantissa);
6608
6609       -----------------
6610       -- Model_Small --
6611       -----------------
6612
6613       when Attribute_Model_Small =>
6614          Float_Attribute_Universal_Real (
6615            IEEES_Model_Small'Universal_Literal_String,
6616            IEEEL_Model_Small'Universal_Literal_String,
6617            IEEEX_Model_Small'Universal_Literal_String,
6618            VAXFF_Model_Small'Universal_Literal_String,
6619            VAXDF_Model_Small'Universal_Literal_String,
6620            VAXGF_Model_Small'Universal_Literal_String,
6621            AAMPS_Model_Small'Universal_Literal_String,
6622            AAMPL_Model_Small'Universal_Literal_String);
6623
6624       -------------
6625       -- Modulus --
6626       -------------
6627
6628       when Attribute_Modulus =>
6629          Fold_Uint (N, Modulus (P_Type), True);
6630
6631       --------------------
6632       -- Null_Parameter --
6633       --------------------
6634
6635       --  Cannot fold, we know the value sort of, but the whole point is
6636       --  that there is no way to talk about this imaginary value except
6637       --  by using the attribute, so we leave it the way it is.
6638
6639       when Attribute_Null_Parameter =>
6640          null;
6641
6642       -----------------
6643       -- Object_Size --
6644       -----------------
6645
6646       --  The Object_Size attribute for a type returns the Esize of the
6647       --  type and can be folded if this value is known.
6648
6649       when Attribute_Object_Size => Object_Size : declare
6650          P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
6651
6652       begin
6653          if Known_Esize (P_TypeA) then
6654             Fold_Uint (N, Esize (P_TypeA), True);
6655          end if;
6656       end Object_Size;
6657
6658       -------------------------
6659       -- Passed_By_Reference --
6660       -------------------------
6661
6662       --  Scalar types are never passed by reference
6663
6664       when Attribute_Passed_By_Reference =>
6665          Fold_Uint (N, False_Value, True);
6666
6667       ---------
6668       -- Pos --
6669       ---------
6670
6671       when Attribute_Pos =>
6672          Fold_Uint (N, Expr_Value (E1), True);
6673
6674       ----------
6675       -- Pred --
6676       ----------
6677
6678       when Attribute_Pred => Pred :
6679       begin
6680          --  Floating-point case
6681
6682          if Is_Floating_Point_Type (P_Type) then
6683             Fold_Ureal (N,
6684               Eval_Fat.Pred (P_Root_Type, Expr_Value_R (E1)), Static);
6685
6686          --  Fixed-point case
6687
6688          elsif Is_Fixed_Point_Type (P_Type) then
6689             Fold_Ureal (N,
6690               Expr_Value_R (E1) - Small_Value (P_Type), True);
6691
6692          --  Modular integer case (wraps)
6693
6694          elsif Is_Modular_Integer_Type (P_Type) then
6695             Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type), Static);
6696
6697          --  Other scalar cases
6698
6699          else
6700             pragma Assert (Is_Scalar_Type (P_Type));
6701
6702             if Is_Enumeration_Type (P_Type)
6703               and then Expr_Value (E1) =
6704                          Expr_Value (Type_Low_Bound (P_Base_Type))
6705             then
6706                Apply_Compile_Time_Constraint_Error
6707                  (N, "Pred of `&''First`",
6708                   CE_Overflow_Check_Failed,
6709                   Ent  => P_Base_Type,
6710                   Warn => not Static);
6711
6712                Check_Expressions;
6713                return;
6714             end if;
6715
6716             Fold_Uint (N, Expr_Value (E1) - 1, Static);
6717          end if;
6718       end Pred;
6719
6720       -----------
6721       -- Range --
6722       -----------
6723
6724       --  No processing required, because by this stage, Range has been
6725       --  replaced by First .. Last, so this branch can never be taken.
6726
6727       when Attribute_Range =>
6728          raise Program_Error;
6729
6730       ------------------
6731       -- Range_Length --
6732       ------------------
6733
6734       when Attribute_Range_Length =>
6735          Set_Bounds;
6736
6737          --  Can fold if both bounds are compile time known
6738
6739          if Compile_Time_Known_Value (Hi_Bound)
6740            and then Compile_Time_Known_Value (Lo_Bound)
6741          then
6742             Fold_Uint (N,
6743               UI_Max
6744                 (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1),
6745                  Static);
6746          end if;
6747
6748          --  One more case is where Hi_Bound and Lo_Bound are compile-time
6749          --  comparable, and we can figure out the difference between them.
6750
6751          declare
6752             Diff : aliased Uint;
6753
6754          begin
6755             case
6756               Compile_Time_Compare
6757                 (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
6758             is
6759                when EQ =>
6760                   Fold_Uint (N, Uint_1, False);
6761
6762                when GT =>
6763                   Fold_Uint (N, Uint_0, False);
6764
6765                when LT =>
6766                   if Diff /= No_Uint then
6767                      Fold_Uint (N, Diff + 1, False);
6768                   end if;
6769
6770                when others =>
6771                   null;
6772             end case;
6773          end;
6774
6775       ---------------
6776       -- Remainder --
6777       ---------------
6778
6779       when Attribute_Remainder => Remainder : declare
6780          X : constant Ureal := Expr_Value_R (E1);
6781          Y : constant Ureal := Expr_Value_R (E2);
6782
6783       begin
6784          if UR_Is_Zero (Y) then
6785             Apply_Compile_Time_Constraint_Error
6786               (N, "division by zero in Remainder",
6787                CE_Overflow_Check_Failed,
6788                Warn => not Static);
6789
6790             Check_Expressions;
6791             return;
6792          end if;
6793
6794          Fold_Ureal (N, Eval_Fat.Remainder (P_Root_Type, X, Y), Static);
6795       end Remainder;
6796
6797       -----------
6798       -- Round --
6799       -----------
6800
6801       when Attribute_Round => Round :
6802       declare
6803          Sr : Ureal;
6804          Si : Uint;
6805
6806       begin
6807          --  First we get the (exact result) in units of small
6808
6809          Sr := Expr_Value_R (E1) / Small_Value (C_Type);
6810
6811          --  Now round that exactly to an integer
6812
6813          Si := UR_To_Uint (Sr);
6814
6815          --  Finally the result is obtained by converting back to real
6816
6817          Fold_Ureal (N, Si * Small_Value (C_Type), Static);
6818       end Round;
6819
6820       --------------
6821       -- Rounding --
6822       --------------
6823
6824       when Attribute_Rounding =>
6825          Fold_Ureal (N,
6826            Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static);
6827
6828       ---------------
6829       -- Safe_Emax --
6830       ---------------
6831
6832       when Attribute_Safe_Emax =>
6833          Float_Attribute_Universal_Integer (
6834            IEEES_Safe_Emax,
6835            IEEEL_Safe_Emax,
6836            IEEEX_Safe_Emax,
6837            VAXFF_Safe_Emax,
6838            VAXDF_Safe_Emax,
6839            VAXGF_Safe_Emax,
6840            AAMPS_Safe_Emax,
6841            AAMPL_Safe_Emax);
6842
6843       ----------------
6844       -- Safe_First --
6845       ----------------
6846
6847       when Attribute_Safe_First =>
6848          Float_Attribute_Universal_Real (
6849            IEEES_Safe_First'Universal_Literal_String,
6850            IEEEL_Safe_First'Universal_Literal_String,
6851            IEEEX_Safe_First'Universal_Literal_String,
6852            VAXFF_Safe_First'Universal_Literal_String,
6853            VAXDF_Safe_First'Universal_Literal_String,
6854            VAXGF_Safe_First'Universal_Literal_String,
6855            AAMPS_Safe_First'Universal_Literal_String,
6856            AAMPL_Safe_First'Universal_Literal_String);
6857
6858       ----------------
6859       -- Safe_Large --
6860       ----------------
6861
6862       when Attribute_Safe_Large =>
6863          if Is_Fixed_Point_Type (P_Type) then
6864             Fold_Ureal
6865               (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static);
6866          else
6867             Float_Attribute_Universal_Real (
6868               IEEES_Safe_Large'Universal_Literal_String,
6869               IEEEL_Safe_Large'Universal_Literal_String,
6870               IEEEX_Safe_Large'Universal_Literal_String,
6871               VAXFF_Safe_Large'Universal_Literal_String,
6872               VAXDF_Safe_Large'Universal_Literal_String,
6873               VAXGF_Safe_Large'Universal_Literal_String,
6874               AAMPS_Safe_Large'Universal_Literal_String,
6875               AAMPL_Safe_Large'Universal_Literal_String);
6876          end if;
6877
6878       ---------------
6879       -- Safe_Last --
6880       ---------------
6881
6882       when Attribute_Safe_Last =>
6883          Float_Attribute_Universal_Real (
6884            IEEES_Safe_Last'Universal_Literal_String,
6885            IEEEL_Safe_Last'Universal_Literal_String,
6886            IEEEX_Safe_Last'Universal_Literal_String,
6887            VAXFF_Safe_Last'Universal_Literal_String,
6888            VAXDF_Safe_Last'Universal_Literal_String,
6889            VAXGF_Safe_Last'Universal_Literal_String,
6890            AAMPS_Safe_Last'Universal_Literal_String,
6891            AAMPL_Safe_Last'Universal_Literal_String);
6892
6893       ----------------
6894       -- Safe_Small --
6895       ----------------
6896
6897       when Attribute_Safe_Small =>
6898
6899          --  In Ada 95, the old Ada 83 attribute Safe_Small is redundant
6900          --  for fixed-point, since is the same as Small, but we implement
6901          --  it for backwards compatibility.
6902
6903          if Is_Fixed_Point_Type (P_Type) then
6904             Fold_Ureal (N, Small_Value (P_Type), Static);
6905
6906          --  Ada 83 Safe_Small for floating-point cases
6907
6908          else
6909             Float_Attribute_Universal_Real (
6910               IEEES_Safe_Small'Universal_Literal_String,
6911               IEEEL_Safe_Small'Universal_Literal_String,
6912               IEEEX_Safe_Small'Universal_Literal_String,
6913               VAXFF_Safe_Small'Universal_Literal_String,
6914               VAXDF_Safe_Small'Universal_Literal_String,
6915               VAXGF_Safe_Small'Universal_Literal_String,
6916               AAMPS_Safe_Small'Universal_Literal_String,
6917               AAMPL_Safe_Small'Universal_Literal_String);
6918          end if;
6919
6920       -----------
6921       -- Scale --
6922       -----------
6923
6924       when Attribute_Scale =>
6925          Fold_Uint (N, Scale_Value (P_Type), True);
6926
6927       -------------
6928       -- Scaling --
6929       -------------
6930
6931       when Attribute_Scaling =>
6932          Fold_Ureal (N,
6933            Eval_Fat.Scaling
6934              (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static);
6935
6936       ------------------
6937       -- Signed_Zeros --
6938       ------------------
6939
6940       when Attribute_Signed_Zeros =>
6941          Fold_Uint
6942            (N, UI_From_Int (Boolean'Pos (Signed_Zeros_On_Target)), Static);
6943
6944       ----------
6945       -- Size --
6946       ----------
6947
6948       --  Size attribute returns the RM size. All scalar types can be folded,
6949       --  as well as any types for which the size is known by the front end,
6950       --  including any type for which a size attribute is specified.
6951
6952       when Attribute_Size | Attribute_VADS_Size => Size : declare
6953          P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
6954
6955       begin
6956          if RM_Size (P_TypeA) /= Uint_0 then
6957
6958             --  VADS_Size case
6959
6960             if Id = Attribute_VADS_Size or else Use_VADS_Size then
6961                declare
6962                   S : constant Node_Id := Size_Clause (P_TypeA);
6963
6964                begin
6965                   --  If a size clause applies, then use the size from it.
6966                   --  This is one of the rare cases where we can use the
6967                   --  Size_Clause field for a subtype when Has_Size_Clause
6968                   --  is False. Consider:
6969
6970                   --    type x is range 1 .. 64;
6971                   --    for x'size use 12;
6972                   --    subtype y is x range 0 .. 3;
6973
6974                   --  Here y has a size clause inherited from x, but normally
6975                   --  it does not apply, and y'size is 2. However, y'VADS_Size
6976                   --  is indeed 12 and not 2.
6977
6978                   if Present (S)
6979                     and then Is_OK_Static_Expression (Expression (S))
6980                   then
6981                      Fold_Uint (N, Expr_Value (Expression (S)), True);
6982
6983                   --  If no size is specified, then we simply use the object
6984                   --  size in the VADS_Size case (e.g. Natural'Size is equal
6985                   --  to Integer'Size, not one less).
6986
6987                   else
6988                      Fold_Uint (N, Esize (P_TypeA), True);
6989                   end if;
6990                end;
6991
6992             --  Normal case (Size) in which case we want the RM_Size
6993
6994             else
6995                Fold_Uint (N,
6996                  RM_Size (P_TypeA),
6997                  Static and then Is_Discrete_Type (P_TypeA));
6998             end if;
6999          end if;
7000       end Size;
7001
7002       -----------
7003       -- Small --
7004       -----------
7005
7006       when Attribute_Small =>
7007
7008          --  The floating-point case is present only for Ada 83 compatibility.
7009          --  Note that strictly this is an illegal addition, since we are
7010          --  extending an Ada 95 defined attribute, but we anticipate an
7011          --  ARG ruling that will permit this.
7012
7013          if Is_Floating_Point_Type (P_Type) then
7014
7015             --  Ada 83 attribute is defined as (RM83 3.5.8)
7016
7017             --    T'Small = 2.0**(-T'Emax - 1)
7018
7019             --  where
7020
7021             --    T'Emax = 4 * T'Mantissa
7022
7023             Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1), Static);
7024
7025          --  Normal Ada 95 fixed-point case
7026
7027          else
7028             Fold_Ureal (N, Small_Value (P_Type), True);
7029          end if;
7030
7031       -----------------
7032       -- Stream_Size --
7033       -----------------
7034
7035       when Attribute_Stream_Size =>
7036          null;
7037
7038       ----------
7039       -- Succ --
7040       ----------
7041
7042       when Attribute_Succ => Succ :
7043       begin
7044          --  Floating-point case
7045
7046          if Is_Floating_Point_Type (P_Type) then
7047             Fold_Ureal (N,
7048               Eval_Fat.Succ (P_Root_Type, Expr_Value_R (E1)), Static);
7049
7050          --  Fixed-point case
7051
7052          elsif Is_Fixed_Point_Type (P_Type) then
7053             Fold_Ureal (N,
7054               Expr_Value_R (E1) + Small_Value (P_Type), Static);
7055
7056          --  Modular integer case (wraps)
7057
7058          elsif Is_Modular_Integer_Type (P_Type) then
7059             Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type), Static);
7060
7061          --  Other scalar cases
7062
7063          else
7064             pragma Assert (Is_Scalar_Type (P_Type));
7065
7066             if Is_Enumeration_Type (P_Type)
7067               and then Expr_Value (E1) =
7068                          Expr_Value (Type_High_Bound (P_Base_Type))
7069             then
7070                Apply_Compile_Time_Constraint_Error
7071                  (N, "Succ of `&''Last`",
7072                   CE_Overflow_Check_Failed,
7073                   Ent  => P_Base_Type,
7074                   Warn => not Static);
7075
7076                Check_Expressions;
7077                return;
7078             else
7079                Fold_Uint (N, Expr_Value (E1) + 1, Static);
7080             end if;
7081          end if;
7082       end Succ;
7083
7084       ----------------
7085       -- Truncation --
7086       ----------------
7087
7088       when Attribute_Truncation =>
7089          Fold_Ureal (N,
7090            Eval_Fat.Truncation (P_Root_Type, Expr_Value_R (E1)), Static);
7091
7092       ----------------
7093       -- Type_Class --
7094       ----------------
7095
7096       when Attribute_Type_Class => Type_Class : declare
7097          Typ : constant Entity_Id := Underlying_Type (P_Base_Type);
7098          Id  : RE_Id;
7099
7100       begin
7101          if Is_Descendent_Of_Address (Typ) then
7102             Id := RE_Type_Class_Address;
7103
7104          elsif Is_Enumeration_Type (Typ) then
7105             Id := RE_Type_Class_Enumeration;
7106
7107          elsif Is_Integer_Type (Typ) then
7108             Id := RE_Type_Class_Integer;
7109
7110          elsif Is_Fixed_Point_Type (Typ) then
7111             Id := RE_Type_Class_Fixed_Point;
7112
7113          elsif Is_Floating_Point_Type (Typ) then
7114             Id := RE_Type_Class_Floating_Point;
7115
7116          elsif Is_Array_Type (Typ) then
7117             Id := RE_Type_Class_Array;
7118
7119          elsif Is_Record_Type (Typ) then
7120             Id := RE_Type_Class_Record;
7121
7122          elsif Is_Access_Type (Typ) then
7123             Id := RE_Type_Class_Access;
7124
7125          elsif Is_Enumeration_Type (Typ) then
7126             Id := RE_Type_Class_Enumeration;
7127
7128          elsif Is_Task_Type (Typ) then
7129             Id := RE_Type_Class_Task;
7130
7131          --  We treat protected types like task types. It would make more
7132          --  sense to have another enumeration value, but after all the
7133          --  whole point of this feature is to be exactly DEC compatible,
7134          --  and changing the type Type_Class would not meet this requirement.
7135
7136          elsif Is_Protected_Type (Typ) then
7137             Id := RE_Type_Class_Task;
7138
7139          --  Not clear if there are any other possibilities, but if there
7140          --  are, then we will treat them as the address case.
7141
7142          else
7143             Id := RE_Type_Class_Address;
7144          end if;
7145
7146          Rewrite (N, New_Occurrence_Of (RTE (Id), Loc));
7147       end Type_Class;
7148
7149       -----------------------
7150       -- Unbiased_Rounding --
7151       -----------------------
7152
7153       when Attribute_Unbiased_Rounding =>
7154          Fold_Ureal (N,
7155            Eval_Fat.Unbiased_Rounding (P_Root_Type, Expr_Value_R (E1)),
7156            Static);
7157
7158       -------------------------
7159       -- Unconstrained_Array --
7160       -------------------------
7161
7162       when Attribute_Unconstrained_Array => Unconstrained_Array : declare
7163          Typ : constant Entity_Id := Underlying_Type (P_Type);
7164
7165       begin
7166          Rewrite (N, New_Occurrence_Of (
7167            Boolean_Literals (
7168              Is_Array_Type (P_Type)
7169               and then not Is_Constrained (Typ)), Loc));
7170
7171          --  Analyze and resolve as boolean, note that this attribute is
7172          --  a static attribute in GNAT.
7173
7174          Analyze_And_Resolve (N, Standard_Boolean);
7175          Static := True;
7176       end Unconstrained_Array;
7177
7178       ---------------
7179       -- VADS_Size --
7180       ---------------
7181
7182       --  Processing is shared with Size
7183
7184       ---------
7185       -- Val --
7186       ---------
7187
7188       when Attribute_Val => Val :
7189       begin
7190          if  Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type))
7191            or else
7192              Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type))
7193          then
7194             Apply_Compile_Time_Constraint_Error
7195               (N, "Val expression out of range",
7196                CE_Range_Check_Failed,
7197                Warn => not Static);
7198
7199             Check_Expressions;
7200             return;
7201
7202          else
7203             Fold_Uint (N, Expr_Value (E1), Static);
7204          end if;
7205       end Val;
7206
7207       ----------------
7208       -- Value_Size --
7209       ----------------
7210
7211       --  The Value_Size attribute for a type returns the RM size of the
7212       --  type. This an always be folded for scalar types, and can also
7213       --  be folded for non-scalar types if the size is set.
7214
7215       when Attribute_Value_Size => Value_Size : declare
7216          P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
7217       begin
7218          if RM_Size (P_TypeA) /= Uint_0 then
7219             Fold_Uint (N, RM_Size (P_TypeA), True);
7220          end if;
7221       end Value_Size;
7222
7223       -------------
7224       -- Version --
7225       -------------
7226
7227       --  Version can never be static
7228
7229       when Attribute_Version =>
7230          null;
7231
7232       ----------------
7233       -- Wide_Image --
7234       ----------------
7235
7236       --  Wide_Image is a scalar attribute, but is never static, because it
7237       --  is not a static function (having a non-scalar argument (RM 4.9(22))
7238
7239       when Attribute_Wide_Image =>
7240          null;
7241
7242       ---------------------
7243       -- Wide_Wide_Image --
7244       ---------------------
7245
7246       --  Wide_Wide_Image is a scalar attribute but is never static, because it
7247       --  is not a static function (having a non-scalar argument (RM 4.9(22)).
7248
7249       when Attribute_Wide_Wide_Image =>
7250          null;
7251
7252       ---------------------
7253       -- Wide_Wide_Width --
7254       ---------------------
7255
7256       --  Processing for Wide_Wide_Width is combined with Width
7257
7258       ----------------
7259       -- Wide_Width --
7260       ----------------
7261
7262       --  Processing for Wide_Width is combined with Width
7263
7264       -----------
7265       -- Width --
7266       -----------
7267
7268       --  This processing also handles the case of Wide_[Wide_]Width
7269
7270       when Attribute_Width |
7271            Attribute_Wide_Width |
7272            Attribute_Wide_Wide_Width => Width :
7273       begin
7274          if Compile_Time_Known_Bounds (P_Type) then
7275
7276             --  Floating-point types
7277
7278             if Is_Floating_Point_Type (P_Type) then
7279
7280                --  Width is zero for a null range (RM 3.5 (38))
7281
7282                if Expr_Value_R (Type_High_Bound (P_Type)) <
7283                   Expr_Value_R (Type_Low_Bound (P_Type))
7284                then
7285                   Fold_Uint (N, Uint_0, True);
7286
7287                else
7288                   --  For floating-point, we have +N.dddE+nnn where length
7289                   --  of ddd is determined by type'Digits - 1, but is one
7290                   --  if Digits is one (RM 3.5 (33)).
7291
7292                   --  nnn is set to 2 for Short_Float and Float (32 bit
7293                   --  floats), and 3 for Long_Float and Long_Long_Float.
7294                   --  For machines where Long_Long_Float is the IEEE
7295                   --  extended precision type, the exponent takes 4 digits.
7296
7297                   declare
7298                      Len : Int :=
7299                              Int'Max (2, UI_To_Int (Digits_Value (P_Type)));
7300
7301                   begin
7302                      if Esize (P_Type) <= 32 then
7303                         Len := Len + 6;
7304                      elsif Esize (P_Type) = 64 then
7305                         Len := Len + 7;
7306                      else
7307                         Len := Len + 8;
7308                      end if;
7309
7310                      Fold_Uint (N, UI_From_Int (Len), True);
7311                   end;
7312                end if;
7313
7314             --  Fixed-point types
7315
7316             elsif Is_Fixed_Point_Type (P_Type) then
7317
7318                --  Width is zero for a null range (RM 3.5 (38))
7319
7320                if Expr_Value (Type_High_Bound (P_Type)) <
7321                   Expr_Value (Type_Low_Bound  (P_Type))
7322                then
7323                   Fold_Uint (N, Uint_0, True);
7324
7325                --  The non-null case depends on the specific real type
7326
7327                else
7328                   --  For fixed-point type width is Fore + 1 + Aft (RM 3.5(34))
7329
7330                   Fold_Uint
7331                     (N, UI_From_Int (Fore_Value + 1 + Aft_Value), True);
7332                end if;
7333
7334             --  Discrete types
7335
7336             else
7337                declare
7338                   R  : constant Entity_Id := Root_Type (P_Type);
7339                   Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type));
7340                   Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type));
7341                   W  : Nat;
7342                   Wt : Nat;
7343                   T  : Uint;
7344                   L  : Node_Id;
7345                   C  : Character;
7346
7347                begin
7348                   --  Empty ranges
7349
7350                   if Lo > Hi then
7351                      W := 0;
7352
7353                   --  Width for types derived from Standard.Character
7354                   --  and Standard.Wide_[Wide_]Character.
7355
7356                   elsif Is_Standard_Character_Type (P_Type) then
7357                      W := 0;
7358
7359                      --  Set W larger if needed
7360
7361                      for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop
7362
7363                         --  All wide characters look like Hex_hhhhhhhh
7364
7365                         if J > 255 then
7366                            W := 12;
7367
7368                         else
7369                            C := Character'Val (J);
7370
7371                            --  Test for all cases where Character'Image
7372                            --  yields an image that is longer than three
7373                            --  characters. First the cases of Reserved_xxx
7374                            --  names (length = 12).
7375
7376                            case C is
7377                               when Reserved_128 | Reserved_129 |
7378                                    Reserved_132 | Reserved_153
7379
7380                                 => Wt := 12;
7381
7382                               when BS | HT | LF | VT | FF | CR |
7383                                    SO | SI | EM | FS | GS | RS |
7384                                    US | RI | MW | ST | PM
7385
7386                                 => Wt := 2;
7387
7388                               when NUL | SOH | STX | ETX | EOT |
7389                                    ENQ | ACK | BEL | DLE | DC1 |
7390                                    DC2 | DC3 | DC4 | NAK | SYN |
7391                                    ETB | CAN | SUB | ESC | DEL |
7392                                    BPH | NBH | NEL | SSA | ESA |
7393                                    HTS | HTJ | VTS | PLD | PLU |
7394                                    SS2 | SS3 | DCS | PU1 | PU2 |
7395                                    STS | CCH | SPA | EPA | SOS |
7396                                    SCI | CSI | OSC | APC
7397
7398                                 => Wt := 3;
7399
7400                               when Space .. Tilde |
7401                                    No_Break_Space .. LC_Y_Diaeresis
7402
7403                                 => Wt := 3;
7404                            end case;
7405
7406                            W := Int'Max (W, Wt);
7407                         end if;
7408                      end loop;
7409
7410                   --  Width for types derived from Standard.Boolean
7411
7412                   elsif R = Standard_Boolean then
7413                      if Lo = 0 then
7414                         W := 5; -- FALSE
7415                      else
7416                         W := 4; -- TRUE
7417                      end if;
7418
7419                   --  Width for integer types
7420
7421                   elsif Is_Integer_Type (P_Type) then
7422                      T := UI_Max (abs Lo, abs Hi);
7423
7424                      W := 2;
7425                      while T >= 10 loop
7426                         W := W + 1;
7427                         T := T / 10;
7428                      end loop;
7429
7430                   --  Only remaining possibility is user declared enum type
7431
7432                   else
7433                      pragma Assert (Is_Enumeration_Type (P_Type));
7434
7435                      W := 0;
7436                      L := First_Literal (P_Type);
7437
7438                      while Present (L) loop
7439
7440                         --  Only pay attention to in range characters
7441
7442                         if Lo <= Enumeration_Pos (L)
7443                           and then Enumeration_Pos (L) <= Hi
7444                         then
7445                            --  For Width case, use decoded name
7446
7447                            if Id = Attribute_Width then
7448                               Get_Decoded_Name_String (Chars (L));
7449                               Wt := Nat (Name_Len);
7450
7451                            --  For Wide_[Wide_]Width, use encoded name, and
7452                            --  then adjust for the encoding.
7453
7454                            else
7455                               Get_Name_String (Chars (L));
7456
7457                               --  Character literals are always of length 3
7458
7459                               if Name_Buffer (1) = 'Q' then
7460                                  Wt := 3;
7461
7462                               --  Otherwise loop to adjust for upper/wide chars
7463
7464                               else
7465                                  Wt := Nat (Name_Len);
7466
7467                                  for J in 1 .. Name_Len loop
7468                                     if Name_Buffer (J) = 'U' then
7469                                        Wt := Wt - 2;
7470                                     elsif Name_Buffer (J) = 'W' then
7471                                        Wt := Wt - 4;
7472                                     end if;
7473                                  end loop;
7474                               end if;
7475                            end if;
7476
7477                            W := Int'Max (W, Wt);
7478                         end if;
7479
7480                         Next_Literal (L);
7481                      end loop;
7482                   end if;
7483
7484                   Fold_Uint (N, UI_From_Int (W), True);
7485                end;
7486             end if;
7487          end if;
7488       end Width;
7489
7490       --  The following attributes denote function that cannot be folded
7491
7492       when Attribute_From_Any |
7493            Attribute_To_Any   |
7494            Attribute_TypeCode =>
7495          null;
7496
7497       --  The following attributes can never be folded, and furthermore we
7498       --  should not even have entered the case statement for any of these.
7499       --  Note that in some cases, the values have already been folded as
7500       --  a result of the processing in Analyze_Attribute.
7501
7502       when Attribute_Abort_Signal             |
7503            Attribute_Access                   |
7504            Attribute_Address                  |
7505            Attribute_Address_Size             |
7506            Attribute_Asm_Input                |
7507            Attribute_Asm_Output               |
7508            Attribute_Base                     |
7509            Attribute_Bit_Order                |
7510            Attribute_Bit_Position             |
7511            Attribute_Callable                 |
7512            Attribute_Caller                   |
7513            Attribute_Class                    |
7514            Attribute_Code_Address             |
7515            Attribute_Compiler_Version         |
7516            Attribute_Count                    |
7517            Attribute_Default_Bit_Order        |
7518            Attribute_Elaborated               |
7519            Attribute_Elab_Body                |
7520            Attribute_Elab_Spec                |
7521            Attribute_Enabled                  |
7522            Attribute_External_Tag             |
7523            Attribute_Fast_Math                |
7524            Attribute_First_Bit                |
7525            Attribute_Input                    |
7526            Attribute_Last_Bit                 |
7527            Attribute_Maximum_Alignment        |
7528            Attribute_Old                      |
7529            Attribute_Output                   |
7530            Attribute_Partition_ID             |
7531            Attribute_Pool_Address             |
7532            Attribute_Position                 |
7533            Attribute_Priority                 |
7534            Attribute_Read                     |
7535            Attribute_Result                   |
7536            Attribute_Storage_Pool             |
7537            Attribute_Storage_Size             |
7538            Attribute_Storage_Unit             |
7539            Attribute_Stub_Type                |
7540            Attribute_Tag                      |
7541            Attribute_Target_Name              |
7542            Attribute_Terminated               |
7543            Attribute_To_Address               |
7544            Attribute_UET_Address              |
7545            Attribute_Unchecked_Access         |
7546            Attribute_Universal_Literal_String |
7547            Attribute_Unrestricted_Access      |
7548            Attribute_Valid                    |
7549            Attribute_Value                    |
7550            Attribute_Wchar_T_Size             |
7551            Attribute_Wide_Value               |
7552            Attribute_Wide_Wide_Value          |
7553            Attribute_Word_Size                |
7554            Attribute_Write                    =>
7555
7556          raise Program_Error;
7557       end case;
7558
7559       --  At the end of the case, one more check. If we did a static evaluation
7560       --  so that the result is now a literal, then set Is_Static_Expression
7561       --  in the constant only if the prefix type is a static subtype. For
7562       --  non-static subtypes, the folding is still OK, but not static.
7563
7564       --  An exception is the GNAT attribute Constrained_Array which is
7565       --  defined to be a static attribute in all cases.
7566
7567       if Nkind_In (N, N_Integer_Literal,
7568                       N_Real_Literal,
7569                       N_Character_Literal,
7570                       N_String_Literal)
7571         or else (Is_Entity_Name (N)
7572                   and then Ekind (Entity (N)) = E_Enumeration_Literal)
7573       then
7574          Set_Is_Static_Expression (N, Static);
7575
7576       --  If this is still an attribute reference, then it has not been folded
7577       --  and that means that its expressions are in a non-static context.
7578
7579       elsif Nkind (N) = N_Attribute_Reference then
7580          Check_Expressions;
7581
7582       --  Note: the else case not covered here are odd cases where the
7583       --  processing has transformed the attribute into something other
7584       --  than a constant. Nothing more to do in such cases.
7585
7586       else
7587          null;
7588       end if;
7589    end Eval_Attribute;
7590
7591    ------------------------------
7592    -- Is_Anonymous_Tagged_Base --
7593    ------------------------------
7594
7595    function Is_Anonymous_Tagged_Base
7596      (Anon : Entity_Id;
7597       Typ  : Entity_Id)
7598       return Boolean
7599    is
7600    begin
7601       return
7602         Anon = Current_Scope
7603           and then Is_Itype (Anon)
7604           and then Associated_Node_For_Itype (Anon) = Parent (Typ);
7605    end Is_Anonymous_Tagged_Base;
7606
7607    --------------------------------
7608    -- Name_Implies_Lvalue_Prefix --
7609    --------------------------------
7610
7611    function Name_Implies_Lvalue_Prefix (Nam : Name_Id) return Boolean is
7612       pragma Assert (Is_Attribute_Name (Nam));
7613    begin
7614       return Attribute_Name_Implies_Lvalue_Prefix (Get_Attribute_Id (Nam));
7615    end Name_Implies_Lvalue_Prefix;
7616
7617    -----------------------
7618    -- Resolve_Attribute --
7619    -----------------------
7620
7621    procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is
7622       Loc      : constant Source_Ptr   := Sloc (N);
7623       P        : constant Node_Id      := Prefix (N);
7624       Aname    : constant Name_Id      := Attribute_Name (N);
7625       Attr_Id  : constant Attribute_Id := Get_Attribute_Id (Aname);
7626       Btyp     : constant Entity_Id    := Base_Type (Typ);
7627       Des_Btyp : Entity_Id;
7628       Index    : Interp_Index;
7629       It       : Interp;
7630       Nom_Subt : Entity_Id;
7631
7632       procedure Accessibility_Message;
7633       --  Error, or warning within an instance, if the static accessibility
7634       --  rules of 3.10.2 are violated.
7635
7636       ---------------------------
7637       -- Accessibility_Message --
7638       ---------------------------
7639
7640       procedure Accessibility_Message is
7641          Indic : Node_Id := Parent (Parent (N));
7642
7643       begin
7644          --  In an instance, this is a runtime check, but one we
7645          --  know will fail, so generate an appropriate warning.
7646
7647          if In_Instance_Body then
7648             Error_Msg_F
7649               ("?non-local pointer cannot point to local object", P);
7650             Error_Msg_F
7651               ("\?Program_Error will be raised at run time", P);
7652             Rewrite (N,
7653               Make_Raise_Program_Error (Loc,
7654                 Reason => PE_Accessibility_Check_Failed));
7655             Set_Etype (N, Typ);
7656             return;
7657
7658          else
7659             Error_Msg_F
7660               ("non-local pointer cannot point to local object", P);
7661
7662             --  Check for case where we have a missing access definition
7663
7664             if Is_Record_Type (Current_Scope)
7665               and then
7666                 Nkind_In (Parent (N), N_Discriminant_Association,
7667                                       N_Index_Or_Discriminant_Constraint)
7668             then
7669                Indic := Parent (Parent (N));
7670                while Present (Indic)
7671                  and then Nkind (Indic) /= N_Subtype_Indication
7672                loop
7673                   Indic := Parent (Indic);
7674                end loop;
7675
7676                if Present (Indic) then
7677                   Error_Msg_NE
7678                     ("\use an access definition for" &
7679                      " the access discriminant of&",
7680                      N, Entity (Subtype_Mark (Indic)));
7681                end if;
7682             end if;
7683          end if;
7684       end Accessibility_Message;
7685
7686    --  Start of processing for Resolve_Attribute
7687
7688    begin
7689       --  If error during analysis, no point in continuing, except for
7690       --  array types, where we get  better recovery by using unconstrained
7691       --  indices than nothing at all (see Check_Array_Type).
7692
7693       if Error_Posted (N)
7694         and then Attr_Id /= Attribute_First
7695         and then Attr_Id /= Attribute_Last
7696         and then Attr_Id /= Attribute_Length
7697         and then Attr_Id /= Attribute_Range
7698       then
7699          return;
7700       end if;
7701
7702       --  If attribute was universal type, reset to actual type
7703
7704       if Etype (N) = Universal_Integer
7705         or else Etype (N) = Universal_Real
7706       then
7707          Set_Etype (N, Typ);
7708       end if;
7709
7710       --  Remaining processing depends on attribute
7711
7712       case Attr_Id is
7713
7714          ------------
7715          -- Access --
7716          ------------
7717
7718          --  For access attributes, if the prefix denotes an entity, it is
7719          --  interpreted as a name, never as a call. It may be overloaded,
7720          --  in which case resolution uses the profile of the context type.
7721          --  Otherwise prefix must be resolved.
7722
7723          when Attribute_Access
7724             | Attribute_Unchecked_Access
7725             | Attribute_Unrestricted_Access =>
7726
7727          Access_Attribute :
7728          begin
7729             if Is_Variable (P) then
7730                Note_Possible_Modification (P, Sure => False);
7731             end if;
7732
7733             --  The following comes from a query by Adam Beneschan, concerning
7734             --  improper use of universal_access in equality tests involving
7735             --  anonymous access types. Another good reason for 'Ref, but
7736             --  for now disable the test, which breaks several filed tests.
7737
7738             if Ekind (Typ) = E_Anonymous_Access_Type
7739               and then Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne)
7740               and then False
7741             then
7742                Error_Msg_N ("need unique type to resolve 'Access", N);
7743                Error_Msg_N ("\qualify attribute with some access type", N);
7744             end if;
7745
7746             if Is_Entity_Name (P) then
7747                if Is_Overloaded (P) then
7748                   Get_First_Interp (P, Index, It);
7749                   while Present (It.Nam) loop
7750                      if Type_Conformant (Designated_Type (Typ), It.Nam) then
7751                         Set_Entity (P, It.Nam);
7752
7753                         --  The prefix is definitely NOT overloaded anymore at
7754                         --  this point, so we reset the Is_Overloaded flag to
7755                         --  avoid any confusion when reanalyzing the node.
7756
7757                         Set_Is_Overloaded (P, False);
7758                         Set_Is_Overloaded (N, False);
7759                         Generate_Reference (Entity (P), P);
7760                         exit;
7761                      end if;
7762
7763                      Get_Next_Interp (Index, It);
7764                   end loop;
7765
7766                --  If Prefix is a subprogram name, it is frozen by this
7767                --  reference:
7768
7769                --    If it is a type, there is nothing to resolve.
7770                --    If it is an object, complete its resolution.
7771
7772                elsif Is_Overloadable (Entity (P)) then
7773
7774                   --  Avoid insertion of freeze actions in spec expression mode
7775
7776                   if not In_Spec_Expression then
7777                      Insert_Actions (N, Freeze_Entity (Entity (P), Loc));
7778                   end if;
7779
7780                elsif Is_Type (Entity (P)) then
7781                   null;
7782                else
7783                   Resolve (P);
7784                end if;
7785
7786                Error_Msg_Name_1 := Aname;
7787
7788                if not Is_Entity_Name (P) then
7789                   null;
7790
7791                elsif Is_Overloadable (Entity (P))
7792                  and then Is_Abstract_Subprogram (Entity (P))
7793                then
7794                   Error_Msg_F ("prefix of % attribute cannot be abstract", P);
7795                   Set_Etype (N, Any_Type);
7796
7797                elsif Convention (Entity (P)) = Convention_Intrinsic then
7798                   if Ekind (Entity (P)) = E_Enumeration_Literal then
7799                      Error_Msg_F
7800                        ("prefix of % attribute cannot be enumeration literal",
7801                         P);
7802                   else
7803                      Error_Msg_F
7804                        ("prefix of % attribute cannot be intrinsic", P);
7805                   end if;
7806
7807                   Set_Etype (N, Any_Type);
7808                end if;
7809
7810                --  Assignments, return statements, components of aggregates,
7811                --  generic instantiations will require convention checks if
7812                --  the type is an access to subprogram. Given that there will
7813                --  also be accessibility checks on those, this is where the
7814                --  checks can eventually be centralized ???
7815
7816                if Ekind (Btyp) = E_Access_Subprogram_Type
7817                     or else
7818                   Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
7819                     or else
7820                   Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type
7821                then
7822                   --  Deal with convention mismatch
7823
7824                   if Convention (Btyp) /= Convention (Entity (P)) then
7825                      Error_Msg_FE
7826                        ("subprogram & has wrong convention", P, Entity (P));
7827
7828                      Error_Msg_FE
7829                        ("\does not match convention of access type &",
7830                         P, Btyp);
7831
7832                      if not Has_Convention_Pragma (Btyp) then
7833                         Error_Msg_FE
7834                           ("\probable missing pragma Convention for &",
7835                            P, Btyp);
7836                      end if;
7837
7838                   else
7839                      Check_Subtype_Conformant
7840                        (New_Id  => Entity (P),
7841                         Old_Id  => Designated_Type (Btyp),
7842                         Err_Loc => P);
7843                   end if;
7844
7845                   if Attr_Id = Attribute_Unchecked_Access then
7846                      Error_Msg_Name_1 := Aname;
7847                      Error_Msg_F
7848                        ("attribute% cannot be applied to a subprogram", P);
7849
7850                   elsif Aname = Name_Unrestricted_Access then
7851                      null;  --  Nothing to check
7852
7853                   --  Check the static accessibility rule of 3.10.2(32).
7854                   --  This rule also applies within the private part of an
7855                   --  instantiation. This rule does not apply to anonymous
7856                   --  access-to-subprogram types in access parameters.
7857
7858                   elsif Attr_Id = Attribute_Access
7859                     and then not In_Instance_Body
7860                     and then
7861                       (Ekind (Btyp) = E_Access_Subprogram_Type
7862                         or else Is_Local_Anonymous_Access (Btyp))
7863
7864                     and then Subprogram_Access_Level (Entity (P)) >
7865                                Type_Access_Level (Btyp)
7866                   then
7867                      Error_Msg_F
7868                        ("subprogram must not be deeper than access type", P);
7869
7870                   --  Check the restriction of 3.10.2(32) that disallows the
7871                   --  access attribute within a generic body when the ultimate
7872                   --  ancestor of the type of the attribute is declared outside
7873                   --  of the generic unit and the subprogram is declared within
7874                   --  that generic unit. This includes any such attribute that
7875                   --  occurs within the body of a generic unit that is a child
7876                   --  of the generic unit where the subprogram is declared.
7877                   --  The rule also prohibits applying the attribute when the
7878                   --  access type is a generic formal access type (since the
7879                   --  level of the actual type is not known). This restriction
7880                   --  does not apply when the attribute type is an anonymous
7881                   --  access-to-subprogram type. Note that this check was
7882                   --  revised by AI-229, because the originally Ada 95 rule
7883                   --  was too lax. The original rule only applied when the
7884                   --  subprogram was declared within the body of the generic,
7885                   --  which allowed the possibility of dangling references).
7886                   --  The rule was also too strict in some case, in that it
7887                   --  didn't permit the access to be declared in the generic
7888                   --  spec, whereas the revised rule does (as long as it's not
7889                   --  a formal type).
7890
7891                   --  There are a couple of subtleties of the test for applying
7892                   --  the check that are worth noting. First, we only apply it
7893                   --  when the levels of the subprogram and access type are the
7894                   --  same (the case where the subprogram is statically deeper
7895                   --  was applied above, and the case where the type is deeper
7896                   --  is always safe). Second, we want the check to apply
7897                   --  within nested generic bodies and generic child unit
7898                   --  bodies, but not to apply to an attribute that appears in
7899                   --  the generic unit's specification. This is done by testing
7900                   --  that the attribute's innermost enclosing generic body is
7901                   --  not the same as the innermost generic body enclosing the
7902                   --  generic unit where the subprogram is declared (we don't
7903                   --  want the check to apply when the access attribute is in
7904                   --  the spec and there's some other generic body enclosing
7905                   --  generic). Finally, there's no point applying the check
7906                   --  when within an instance, because any violations will have
7907                   --  been caught by the compilation of the generic unit.
7908
7909                   elsif Attr_Id = Attribute_Access
7910                     and then not In_Instance
7911                     and then Present (Enclosing_Generic_Unit (Entity (P)))
7912                     and then Present (Enclosing_Generic_Body (N))
7913                     and then Enclosing_Generic_Body (N) /=
7914                                Enclosing_Generic_Body
7915                                  (Enclosing_Generic_Unit (Entity (P)))
7916                     and then Subprogram_Access_Level (Entity (P)) =
7917                                Type_Access_Level (Btyp)
7918                     and then Ekind (Btyp) /=
7919                                E_Anonymous_Access_Subprogram_Type
7920                     and then Ekind (Btyp) /=
7921                                E_Anonymous_Access_Protected_Subprogram_Type
7922                   then
7923                      --  The attribute type's ultimate ancestor must be
7924                      --  declared within the same generic unit as the
7925                      --  subprogram is declared. The error message is
7926                      --  specialized to say "ancestor" for the case where
7927                      --  the access type is not its own ancestor, since
7928                      --  saying simply "access type" would be very confusing.
7929
7930                      if Enclosing_Generic_Unit (Entity (P)) /=
7931                           Enclosing_Generic_Unit (Root_Type (Btyp))
7932                      then
7933                         Error_Msg_N
7934                           ("''Access attribute not allowed in generic body",
7935                            N);
7936
7937                         if Root_Type (Btyp) = Btyp then
7938                            Error_Msg_NE
7939                              ("\because " &
7940                               "access type & is declared outside " &
7941                               "generic unit (RM 3.10.2(32))", N, Btyp);
7942                         else
7943                            Error_Msg_NE
7944                              ("\because ancestor of " &
7945                               "access type & is declared outside " &
7946                               "generic unit (RM 3.10.2(32))", N, Btyp);
7947                         end if;
7948
7949                         Error_Msg_NE
7950                           ("\move ''Access to private part, or " &
7951                            "(Ada 2005) use anonymous access type instead of &",
7952                            N, Btyp);
7953
7954                      --  If the ultimate ancestor of the attribute's type is
7955                      --  a formal type, then the attribute is illegal because
7956                      --  the actual type might be declared at a higher level.
7957                      --  The error message is specialized to say "ancestor"
7958                      --  for the case where the access type is not its own
7959                      --  ancestor, since saying simply "access type" would be
7960                      --  very confusing.
7961
7962                      elsif Is_Generic_Type (Root_Type (Btyp)) then
7963                         if Root_Type (Btyp) = Btyp then
7964                            Error_Msg_N
7965                              ("access type must not be a generic formal type",
7966                               N);
7967                         else
7968                            Error_Msg_N
7969                              ("ancestor access type must not be a generic " &
7970                               "formal type", N);
7971                         end if;
7972                      end if;
7973                   end if;
7974                end if;
7975
7976                --  If this is a renaming, an inherited operation, or a
7977                --  subprogram instance, use the original entity. This may make
7978                --  the node type-inconsistent, so this transformation can only
7979                --  be done if the node will not be reanalyzed. In particular,
7980                --  if it is within a default expression, the transformation
7981                --  must be delayed until the default subprogram is created for
7982                --  it, when the enclosing subprogram is frozen.
7983
7984                if Is_Entity_Name (P)
7985                  and then Is_Overloadable (Entity (P))
7986                  and then Present (Alias (Entity (P)))
7987                  and then Expander_Active
7988                then
7989                   Rewrite (P,
7990                     New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
7991                end if;
7992
7993             elsif Nkind (P) = N_Selected_Component
7994               and then Is_Overloadable (Entity (Selector_Name (P)))
7995             then
7996                --  Protected operation. If operation is overloaded, must
7997                --  disambiguate. Prefix that denotes protected object itself
7998                --  is resolved with its own type.
7999
8000                if Attr_Id = Attribute_Unchecked_Access then
8001                   Error_Msg_Name_1 := Aname;
8002                   Error_Msg_F
8003                     ("attribute% cannot be applied to protected operation", P);
8004                end if;
8005
8006                Resolve (Prefix (P));
8007                Generate_Reference (Entity (Selector_Name (P)), P);
8008
8009             elsif Is_Overloaded (P) then
8010
8011                --  Use the designated type of the context to disambiguate
8012                --  Note that this was not strictly conformant to Ada 95,
8013                --  but was the implementation adopted by most Ada 95 compilers.
8014                --  The use of the context type to resolve an Access attribute
8015                --  reference is now mandated in AI-235 for Ada 2005.
8016
8017                declare
8018                   Index : Interp_Index;
8019                   It    : Interp;
8020
8021                begin
8022                   Get_First_Interp (P, Index, It);
8023                   while Present (It.Typ) loop
8024                      if Covers (Designated_Type (Typ), It.Typ) then
8025                         Resolve (P, It.Typ);
8026                         exit;
8027                      end if;
8028
8029                      Get_Next_Interp (Index, It);
8030                   end loop;
8031                end;
8032             else
8033                Resolve (P);
8034             end if;
8035
8036             --  X'Access is illegal if X denotes a constant and the access type
8037             --  is access-to-variable. Same for 'Unchecked_Access. The rule
8038             --  does not apply to 'Unrestricted_Access. If the reference is a
8039             --  default-initialized aggregate component for a self-referential
8040             --  type the reference is legal.
8041
8042             if not (Ekind (Btyp) = E_Access_Subprogram_Type
8043                      or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
8044                      or else (Is_Record_Type (Btyp)
8045                                and then
8046                                  Present (Corresponding_Remote_Type (Btyp)))
8047                      or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type
8048                      or else Ekind (Btyp)
8049                                = E_Anonymous_Access_Protected_Subprogram_Type
8050                      or else Is_Access_Constant (Btyp)
8051                      or else Is_Variable (P)
8052                      or else Attr_Id = Attribute_Unrestricted_Access)
8053             then
8054                if Is_Entity_Name (P)
8055                  and then Is_Type (Entity (P))
8056                then
8057                   --  Legality of a self-reference through an access
8058                   --  attribute has been verified in Analyze_Access_Attribute.
8059
8060                   null;
8061
8062                elsif Comes_From_Source (N) then
8063                   Error_Msg_F ("access-to-variable designates constant", P);
8064                end if;
8065             end if;
8066
8067             Des_Btyp := Designated_Type (Btyp);
8068
8069             if Ada_Version >= Ada_05
8070               and then Is_Incomplete_Type (Des_Btyp)
8071             then
8072                --  Ada 2005 (AI-412): If the (sub)type is a limited view of an
8073                --  imported entity, and the non-limited view is visible, make
8074                --  use of it. If it is an incomplete subtype, use the base type
8075                --  in any case.
8076
8077                if From_With_Type (Des_Btyp)
8078                  and then Present (Non_Limited_View (Des_Btyp))
8079                then
8080                   Des_Btyp := Non_Limited_View (Des_Btyp);
8081
8082                elsif Ekind (Des_Btyp) = E_Incomplete_Subtype then
8083                   Des_Btyp := Etype (Des_Btyp);
8084                end if;
8085             end if;
8086
8087             if (Attr_Id = Attribute_Access
8088                   or else
8089                 Attr_Id = Attribute_Unchecked_Access)
8090               and then (Ekind (Btyp) = E_General_Access_Type
8091                           or else Ekind (Btyp) = E_Anonymous_Access_Type)
8092             then
8093                --  Ada 2005 (AI-230): Check the accessibility of anonymous
8094                --  access types for stand-alone objects, record and array
8095                --  components, and return objects. For a component definition
8096                --  the level is the same of the enclosing composite type.
8097
8098                if Ada_Version >= Ada_05
8099                  and then Is_Local_Anonymous_Access (Btyp)
8100                  and then Object_Access_Level (P) > Type_Access_Level (Btyp)
8101                  and then Attr_Id = Attribute_Access
8102                then
8103                   --  In an instance, this is a runtime check, but one we
8104                   --  know will fail, so generate an appropriate warning.
8105
8106                   if In_Instance_Body then
8107                      Error_Msg_F
8108                        ("?non-local pointer cannot point to local object", P);
8109                      Error_Msg_F
8110                        ("\?Program_Error will be raised at run time", P);
8111                      Rewrite (N,
8112                        Make_Raise_Program_Error (Loc,
8113                          Reason => PE_Accessibility_Check_Failed));
8114                      Set_Etype (N, Typ);
8115
8116                   else
8117                      Error_Msg_F
8118                        ("non-local pointer cannot point to local object", P);
8119                   end if;
8120                end if;
8121
8122                if Is_Dependent_Component_Of_Mutable_Object (P) then
8123                   Error_Msg_F
8124                     ("illegal attribute for discriminant-dependent component",
8125                      P);
8126                end if;
8127
8128                --  Check static matching rule of 3.10.2(27). Nominal subtype
8129                --  of the prefix must statically match the designated type.
8130
8131                Nom_Subt := Etype (P);
8132
8133                if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then
8134                   Nom_Subt := Base_Type (Nom_Subt);
8135                end if;
8136
8137                if Is_Tagged_Type (Designated_Type (Typ)) then
8138
8139                   --  If the attribute is in the context of an access
8140                   --  parameter, then the prefix is allowed to be of the
8141                   --  class-wide type (by AI-127).
8142
8143                   if Ekind (Typ) = E_Anonymous_Access_Type then
8144                      if not Covers (Designated_Type (Typ), Nom_Subt)
8145                        and then not Covers (Nom_Subt, Designated_Type (Typ))
8146                      then
8147                         declare
8148                            Desig : Entity_Id;
8149
8150                         begin
8151                            Desig := Designated_Type (Typ);
8152
8153                            if Is_Class_Wide_Type (Desig) then
8154                               Desig := Etype (Desig);
8155                            end if;
8156
8157                            if Is_Anonymous_Tagged_Base (Nom_Subt, Desig) then
8158                               null;
8159
8160                            else
8161                               Error_Msg_FE
8162                                 ("type of prefix: & not compatible",
8163                                   P, Nom_Subt);
8164                               Error_Msg_FE
8165                                 ("\with &, the expected designated type",
8166                                   P, Designated_Type (Typ));
8167                            end if;
8168                         end;
8169                      end if;
8170
8171                   elsif not Covers (Designated_Type (Typ), Nom_Subt)
8172                     or else
8173                       (not Is_Class_Wide_Type (Designated_Type (Typ))
8174                         and then Is_Class_Wide_Type (Nom_Subt))
8175                   then
8176                      Error_Msg_FE
8177                        ("type of prefix: & is not covered", P, Nom_Subt);
8178                      Error_Msg_FE
8179                        ("\by &, the expected designated type" &
8180                            " (RM 3.10.2 (27))", P, Designated_Type (Typ));
8181                   end if;
8182
8183                   if Is_Class_Wide_Type (Designated_Type (Typ))
8184                     and then Has_Discriminants (Etype (Designated_Type (Typ)))
8185                     and then Is_Constrained (Etype (Designated_Type (Typ)))
8186                     and then Designated_Type (Typ) /= Nom_Subt
8187                   then
8188                      Apply_Discriminant_Check
8189                        (N, Etype (Designated_Type (Typ)));
8190                   end if;
8191
8192                --  Ada 2005 (AI-363): Require static matching when designated
8193                --  type has discriminants and a constrained partial view, since
8194                --  in general objects of such types are mutable, so we can't
8195                --  allow the access value to designate a constrained object
8196                --  (because access values must be assumed to designate mutable
8197                --  objects when designated type does not impose a constraint).
8198
8199                elsif Subtypes_Statically_Match (Des_Btyp, Nom_Subt) then
8200                   null;
8201
8202                elsif Has_Discriminants (Designated_Type (Typ))
8203                  and then not Is_Constrained (Des_Btyp)
8204                  and then
8205                    (Ada_Version < Ada_05
8206                      or else
8207                        not Has_Constrained_Partial_View
8208                              (Designated_Type (Base_Type (Typ))))
8209                then
8210                   null;
8211
8212                else
8213                   Error_Msg_F
8214                     ("object subtype must statically match "
8215                      & "designated subtype", P);
8216
8217                   if Is_Entity_Name (P)
8218                     and then Is_Array_Type (Designated_Type (Typ))
8219                   then
8220                      declare
8221                         D : constant Node_Id := Declaration_Node (Entity (P));
8222
8223                      begin
8224                         Error_Msg_N ("aliased object has explicit bounds?",
8225                           D);
8226                         Error_Msg_N ("\declare without bounds"
8227                           & " (and with explicit initialization)?", D);
8228                         Error_Msg_N ("\for use with unconstrained access?", D);
8229                      end;
8230                   end if;
8231                end if;
8232
8233                --  Check the static accessibility rule of 3.10.2(28).
8234                --  Note that this check is not performed for the
8235                --  case of an anonymous access type, since the access
8236                --  attribute is always legal in such a context.
8237
8238                if Attr_Id /= Attribute_Unchecked_Access
8239                  and then Object_Access_Level (P) > Type_Access_Level (Btyp)
8240                  and then Ekind (Btyp) = E_General_Access_Type
8241                then
8242                   Accessibility_Message;
8243                   return;
8244                end if;
8245             end if;
8246
8247             if Ekind (Btyp) = E_Access_Protected_Subprogram_Type
8248                  or else
8249                Ekind (Btyp) = E_Anonymous_Access_Protected_Subprogram_Type
8250             then
8251                if Is_Entity_Name (P)
8252                  and then not Is_Protected_Type (Scope (Entity (P)))
8253                then
8254                   Error_Msg_F ("context requires a protected subprogram", P);
8255
8256                --  Check accessibility of protected object against that of the
8257                --  access type, but only on user code, because the expander
8258                --  creates access references for handlers. If the context is an
8259                --  anonymous_access_to_protected, there are no accessibility
8260                --  checks either. Omit check entirely for Unrestricted_Access.
8261
8262                elsif Object_Access_Level (P) > Type_Access_Level (Btyp)
8263                  and then Comes_From_Source (N)
8264                  and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type
8265                  and then Attr_Id /= Attribute_Unrestricted_Access
8266                then
8267                   Accessibility_Message;
8268                   return;
8269                end if;
8270
8271             elsif (Ekind (Btyp) = E_Access_Subprogram_Type
8272                      or else
8273                    Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type)
8274               and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type
8275             then
8276                Error_Msg_F ("context requires a non-protected subprogram", P);
8277             end if;
8278
8279             --  The context cannot be a pool-specific type, but this is a
8280             --  legality rule, not a resolution rule, so it must be checked
8281             --  separately, after possibly disambiguation (see AI-245).
8282
8283             if Ekind (Btyp) = E_Access_Type
8284               and then Attr_Id /= Attribute_Unrestricted_Access
8285             then
8286                Wrong_Type (N, Typ);
8287             end if;
8288
8289             --  The context may be a constrained access type (however ill-
8290             --  advised such subtypes might be) so in order to generate a
8291             --  constraint check when needed set the type of the attribute
8292             --  reference to the base type of the context.
8293
8294             Set_Etype (N, Btyp);
8295
8296             --  Check for incorrect atomic/volatile reference (RM C.6(12))
8297
8298             if Attr_Id /= Attribute_Unrestricted_Access then
8299                if Is_Atomic_Object (P)
8300                  and then not Is_Atomic (Designated_Type (Typ))
8301                then
8302                   Error_Msg_F
8303                     ("access to atomic object cannot yield access-to-" &
8304                      "non-atomic type", P);
8305
8306                elsif Is_Volatile_Object (P)
8307                  and then not Is_Volatile (Designated_Type (Typ))
8308                then
8309                   Error_Msg_F
8310                     ("access to volatile object cannot yield access-to-" &
8311                      "non-volatile type", P);
8312                end if;
8313             end if;
8314
8315             if Is_Entity_Name (P) then
8316                Set_Address_Taken (Entity (P));
8317             end if;
8318          end Access_Attribute;
8319
8320          -------------
8321          -- Address --
8322          -------------
8323
8324          --  Deal with resolving the type for Address attribute, overloading
8325          --  is not permitted here, since there is no context to resolve it.
8326
8327          when Attribute_Address | Attribute_Code_Address =>
8328          Address_Attribute : begin
8329
8330             --  To be safe, assume that if the address of a variable is taken,
8331             --  it may be modified via this address, so note modification.
8332
8333             if Is_Variable (P) then
8334                Note_Possible_Modification (P, Sure => False);
8335             end if;
8336
8337             if Nkind (P) in N_Subexpr
8338               and then Is_Overloaded (P)
8339             then
8340                Get_First_Interp (P, Index, It);
8341                Get_Next_Interp (Index, It);
8342
8343                if Present (It.Nam) then
8344                   Error_Msg_Name_1 := Aname;
8345                   Error_Msg_F
8346                     ("prefix of % attribute cannot be overloaded", P);
8347                end if;
8348             end if;
8349
8350             if not Is_Entity_Name (P)
8351               or else not Is_Overloadable (Entity (P))
8352             then
8353                if not Is_Task_Type (Etype (P))
8354                  or else Nkind (P) = N_Explicit_Dereference
8355                then
8356                   Resolve (P);
8357                end if;
8358             end if;
8359
8360             --  If this is the name of a derived subprogram, or that of a
8361             --  generic actual, the address is that of the original entity.
8362
8363             if Is_Entity_Name (P)
8364               and then Is_Overloadable (Entity (P))
8365               and then Present (Alias (Entity (P)))
8366             then
8367                Rewrite (P,
8368                  New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
8369             end if;
8370
8371             if Is_Entity_Name (P) then
8372                Set_Address_Taken (Entity (P));
8373             end if;
8374
8375             if Nkind (P) = N_Slice then
8376
8377                --  Arr (X .. Y)'address is identical to Arr (X)'address,
8378                --  even if the array is packed and the slice itself is not
8379                --  addressable. Transform the prefix into an indexed component.
8380
8381                --  Note that the transformation is safe only if we know that
8382                --  the slice is non-null. That is because a null slice can have
8383                --  an out of bounds index value.
8384
8385                --  Right now, gigi blows up if given 'Address on a slice as a
8386                --  result of some incorrect freeze nodes generated by the front
8387                --  end, and this covers up that bug in one case, but the bug is
8388                --  likely still there in the cases not handled by this code ???
8389
8390                --  It's not clear what 'Address *should* return for a null
8391                --  slice with out of bounds indexes, this might be worth an ARG
8392                --  discussion ???
8393
8394                --  One approach would be to do a length check unconditionally,
8395                --  and then do the transformation below unconditionally, but
8396                --  analyze with checks off, avoiding the problem of the out of
8397                --  bounds index. This approach would interpret the address of
8398                --  an out of bounds null slice as being the address where the
8399                --  array element would be if there was one, which is probably
8400                --  as reasonable an interpretation as any ???
8401
8402                declare
8403                   Loc : constant Source_Ptr := Sloc (P);
8404                   D   : constant Node_Id := Discrete_Range (P);
8405                   Lo  : Node_Id;
8406
8407                begin
8408                   if Is_Entity_Name (D)
8409                     and then
8410                       Not_Null_Range
8411                         (Type_Low_Bound (Entity (D)),
8412                          Type_High_Bound (Entity (D)))
8413                   then
8414                      Lo :=
8415                        Make_Attribute_Reference (Loc,
8416                           Prefix => (New_Occurrence_Of (Entity (D), Loc)),
8417                           Attribute_Name => Name_First);
8418
8419                   elsif Nkind (D) = N_Range
8420                     and then Not_Null_Range (Low_Bound (D), High_Bound (D))
8421                   then
8422                      Lo := Low_Bound (D);
8423
8424                   else
8425                      Lo := Empty;
8426                   end if;
8427
8428                   if Present (Lo) then
8429                      Rewrite (P,
8430                         Make_Indexed_Component (Loc,
8431                            Prefix =>  Relocate_Node (Prefix (P)),
8432                            Expressions => New_List (Lo)));
8433
8434                      Analyze_And_Resolve (P);
8435                   end if;
8436                end;
8437             end if;
8438          end Address_Attribute;
8439
8440          ---------------
8441          -- AST_Entry --
8442          ---------------
8443
8444          --  Prefix of the AST_Entry attribute is an entry name which must
8445          --  not be resolved, since this is definitely not an entry call.
8446
8447          when Attribute_AST_Entry =>
8448             null;
8449
8450          ------------------
8451          -- Body_Version --
8452          ------------------
8453
8454          --  Prefix of Body_Version attribute can be a subprogram name which
8455          --  must not be resolved, since this is not a call.
8456
8457          when Attribute_Body_Version =>
8458             null;
8459
8460          ------------
8461          -- Caller --
8462          ------------
8463
8464          --  Prefix of Caller attribute is an entry name which must not
8465          --  be resolved, since this is definitely not an entry call.
8466
8467          when Attribute_Caller =>
8468             null;
8469
8470          ------------------
8471          -- Code_Address --
8472          ------------------
8473
8474          --  Shares processing with Address attribute
8475
8476          -----------
8477          -- Count --
8478          -----------
8479
8480          --  If the prefix of the Count attribute is an entry name it must not
8481          --  be resolved, since this is definitely not an entry call. However,
8482          --  if it is an element of an entry family, the index itself may
8483          --  have to be resolved because it can be a general expression.
8484
8485          when Attribute_Count =>
8486             if Nkind (P) = N_Indexed_Component
8487               and then Is_Entity_Name (Prefix (P))
8488             then
8489                declare
8490                   Indx : constant Node_Id   := First (Expressions (P));
8491                   Fam  : constant Entity_Id := Entity (Prefix (P));
8492                begin
8493                   Resolve (Indx, Entry_Index_Type (Fam));
8494                   Apply_Range_Check (Indx, Entry_Index_Type (Fam));
8495                end;
8496             end if;
8497
8498          ----------------
8499          -- Elaborated --
8500          ----------------
8501
8502          --  Prefix of the Elaborated attribute is a subprogram name which
8503          --  must not be resolved, since this is definitely not a call. Note
8504          --  that it is a library unit, so it cannot be overloaded here.
8505
8506          when Attribute_Elaborated =>
8507             null;
8508
8509          -------------
8510          -- Enabled --
8511          -------------
8512
8513          --  Prefix of Enabled attribute is a check name, which must be treated
8514          --  specially and not touched by Resolve.
8515
8516          when Attribute_Enabled =>
8517             null;
8518
8519          --------------------
8520          -- Mechanism_Code --
8521          --------------------
8522
8523          --  Prefix of the Mechanism_Code attribute is a function name
8524          --  which must not be resolved. Should we check for overloaded ???
8525
8526          when Attribute_Mechanism_Code =>
8527             null;
8528
8529          ------------------
8530          -- Partition_ID --
8531          ------------------
8532
8533          --  Most processing is done in sem_dist, after determining the
8534          --  context type. Node is rewritten as a conversion to a runtime call.
8535
8536          when Attribute_Partition_ID =>
8537             Process_Partition_Id (N);
8538             return;
8539
8540          ------------------
8541          -- Pool_Address --
8542          ------------------
8543
8544          when Attribute_Pool_Address =>
8545             Resolve (P);
8546
8547          -----------
8548          -- Range --
8549          -----------
8550
8551          --  We replace the Range attribute node with a range expression
8552          --  whose bounds are the 'First and 'Last attributes applied to the
8553          --  same prefix. The reason that we do this transformation here
8554          --  instead of in the expander is that it simplifies other parts of
8555          --  the semantic analysis which assume that the Range has been
8556          --  replaced; thus it must be done even when in semantic-only mode
8557          --  (note that the RM specifically mentions this equivalence, we
8558          --  take care that the prefix is only evaluated once).
8559
8560          when Attribute_Range => Range_Attribute :
8561             declare
8562                LB   : Node_Id;
8563                HB   : Node_Id;
8564
8565             begin
8566                if not Is_Entity_Name (P)
8567                  or else not Is_Type (Entity (P))
8568                then
8569                   Resolve (P);
8570                end if;
8571
8572                HB :=
8573                  Make_Attribute_Reference (Loc,
8574                    Prefix         =>
8575                      Duplicate_Subexpr (P, Name_Req => True),
8576                    Attribute_Name => Name_Last,
8577                    Expressions    => Expressions (N));
8578
8579                LB :=
8580                  Make_Attribute_Reference (Loc,
8581                    Prefix         => P,
8582                    Attribute_Name => Name_First,
8583                    Expressions    => Expressions (N));
8584
8585                --  If the original was marked as Must_Not_Freeze (see code
8586                --  in Sem_Ch3.Make_Index), then make sure the rewriting
8587                --  does not freeze either.
8588
8589                if Must_Not_Freeze (N) then
8590                   Set_Must_Not_Freeze (HB);
8591                   Set_Must_Not_Freeze (LB);
8592                   Set_Must_Not_Freeze (Prefix (HB));
8593                   Set_Must_Not_Freeze (Prefix (LB));
8594                end if;
8595
8596                if Raises_Constraint_Error (Prefix (N)) then
8597
8598                   --  Preserve Sloc of prefix in the new bounds, so that
8599                   --  the posted warning can be removed if we are within
8600                   --  unreachable code.
8601
8602                   Set_Sloc (LB, Sloc (Prefix (N)));
8603                   Set_Sloc (HB, Sloc (Prefix (N)));
8604                end if;
8605
8606                Rewrite (N, Make_Range (Loc, LB, HB));
8607                Analyze_And_Resolve (N, Typ);
8608
8609                --  Normally after resolving attribute nodes, Eval_Attribute
8610                --  is called to do any possible static evaluation of the node.
8611                --  However, here since the Range attribute has just been
8612                --  transformed into a range expression it is no longer an
8613                --  attribute node and therefore the call needs to be avoided
8614                --  and is accomplished by simply returning from the procedure.
8615
8616                return;
8617             end Range_Attribute;
8618
8619          ------------
8620          -- Result --
8621          ------------
8622
8623          --  We will only come here during the prescan of a spec expression
8624          --  containing a Result attribute. In that case the proper Etype has
8625          --  already been set, and nothing more needs to be done here.
8626
8627          when Attribute_Result =>
8628             null;
8629
8630          -----------------
8631          -- UET_Address --
8632          -----------------
8633
8634          --  Prefix must not be resolved in this case, since it is not a
8635          --  real entity reference. No action of any kind is require!
8636
8637          when Attribute_UET_Address =>
8638             return;
8639
8640          ----------------------
8641          -- Unchecked_Access --
8642          ----------------------
8643
8644          --  Processing is shared with Access
8645
8646          -------------------------
8647          -- Unrestricted_Access --
8648          -------------------------
8649
8650          --  Processing is shared with Access
8651
8652          ---------
8653          -- Val --
8654          ---------
8655
8656          --  Apply range check. Note that we did not do this during the
8657          --  analysis phase, since we wanted Eval_Attribute to have a
8658          --  chance at finding an illegal out of range value.
8659
8660          when Attribute_Val =>
8661
8662             --  Note that we do our own Eval_Attribute call here rather than
8663             --  use the common one, because we need to do processing after
8664             --  the call, as per above comment.
8665
8666             Eval_Attribute (N);
8667
8668             --  Eval_Attribute may replace the node with a raise CE, or
8669             --  fold it to a constant. Obviously we only apply a scalar
8670             --  range check if this did not happen!
8671
8672             if Nkind (N) = N_Attribute_Reference
8673               and then Attribute_Name (N) = Name_Val
8674             then
8675                Apply_Scalar_Range_Check (First (Expressions (N)), Btyp);
8676             end if;
8677
8678             return;
8679
8680          -------------
8681          -- Version --
8682          -------------
8683
8684          --  Prefix of Version attribute can be a subprogram name which
8685          --  must not be resolved, since this is not a call.
8686
8687          when Attribute_Version =>
8688             null;
8689
8690          ----------------------
8691          -- Other Attributes --
8692          ----------------------
8693
8694          --  For other attributes, resolve prefix unless it is a type. If
8695          --  the attribute reference itself is a type name ('Base and 'Class)
8696          --  then this is only legal within a task or protected record.
8697
8698          when others =>
8699             if not Is_Entity_Name (P)
8700               or else not Is_Type (Entity (P))
8701             then
8702                Resolve (P);
8703             end if;
8704
8705             --  If the attribute reference itself is a type name ('Base,
8706             --  'Class) then this is only legal within a task or protected
8707             --  record. What is this all about ???
8708
8709             if Is_Entity_Name (N)
8710               and then Is_Type (Entity (N))
8711             then
8712                if Is_Concurrent_Type (Entity (N))
8713                  and then In_Open_Scopes (Entity (P))
8714                then
8715                   null;
8716                else
8717                   Error_Msg_N
8718                     ("invalid use of subtype name in expression or call", N);
8719                end if;
8720             end if;
8721
8722             --  For attributes whose argument may be a string, complete
8723             --  resolution of argument now. This avoids premature expansion
8724             --  (and the creation of transient scopes) before the attribute
8725             --  reference is resolved.
8726
8727             case Attr_Id is
8728                when Attribute_Value =>
8729                   Resolve (First (Expressions (N)), Standard_String);
8730
8731                when Attribute_Wide_Value =>
8732                   Resolve (First (Expressions (N)), Standard_Wide_String);
8733
8734                when Attribute_Wide_Wide_Value =>
8735                   Resolve (First (Expressions (N)), Standard_Wide_Wide_String);
8736
8737                when others => null;
8738             end case;
8739
8740             --  If the prefix of the attribute is a class-wide type then it
8741             --  will be expanded into a dispatching call to a predefined
8742             --  primitive. Therefore we must check for potential violation
8743             --  of such restriction.
8744
8745             if Is_Class_Wide_Type (Etype (P)) then
8746                Check_Restriction (No_Dispatching_Calls, N);
8747             end if;
8748       end case;
8749
8750       --  Normally the Freezing is done by Resolve but sometimes the Prefix
8751       --  is not resolved, in which case the freezing must be done now.
8752
8753       Freeze_Expression (P);
8754
8755       --  Finally perform static evaluation on the attribute reference
8756
8757       Eval_Attribute (N);
8758    end Resolve_Attribute;
8759
8760    --------------------------------
8761    -- Stream_Attribute_Available --
8762    --------------------------------
8763
8764    function Stream_Attribute_Available
8765      (Typ          : Entity_Id;
8766       Nam          : TSS_Name_Type;
8767       Partial_View : Node_Id := Empty) return Boolean
8768    is
8769       Etyp : Entity_Id := Typ;
8770
8771    --  Start of processing for Stream_Attribute_Available
8772
8773    begin
8774       --  We need some comments in this body ???
8775
8776       if Has_Stream_Attribute_Definition (Typ, Nam) then
8777          return True;
8778       end if;
8779
8780       if Is_Class_Wide_Type (Typ) then
8781          return not Is_Limited_Type (Typ)
8782            or else Stream_Attribute_Available (Etype (Typ), Nam);
8783       end if;
8784
8785       if Nam = TSS_Stream_Input
8786         and then Is_Abstract_Type (Typ)
8787         and then not Is_Class_Wide_Type (Typ)
8788       then
8789          return False;
8790       end if;
8791
8792       if not (Is_Limited_Type (Typ)
8793         or else (Present (Partial_View)
8794                    and then Is_Limited_Type (Partial_View)))
8795       then
8796          return True;
8797       end if;
8798
8799       --  In Ada 2005, Input can invoke Read, and Output can invoke Write
8800
8801       if Nam = TSS_Stream_Input
8802         and then Ada_Version >= Ada_05
8803         and then Stream_Attribute_Available (Etyp, TSS_Stream_Read)
8804       then
8805          return True;
8806
8807       elsif Nam = TSS_Stream_Output
8808         and then Ada_Version >= Ada_05
8809         and then Stream_Attribute_Available (Etyp, TSS_Stream_Write)
8810       then
8811          return True;
8812       end if;
8813
8814       --  Case of Read and Write: check for attribute definition clause that
8815       --  applies to an ancestor type.
8816
8817       while Etype (Etyp) /= Etyp loop
8818          Etyp := Etype (Etyp);
8819
8820          if Has_Stream_Attribute_Definition (Etyp, Nam) then
8821             return True;
8822          end if;
8823       end loop;
8824
8825       if Ada_Version < Ada_05 then
8826
8827          --  In Ada 95 mode, also consider a non-visible definition
8828
8829          declare
8830             Btyp : constant Entity_Id := Implementation_Base_Type (Typ);
8831          begin
8832             return Btyp /= Typ
8833               and then Stream_Attribute_Available
8834                          (Btyp, Nam, Partial_View => Typ);
8835          end;
8836       end if;
8837
8838       return False;
8839    end Stream_Attribute_Available;
8840
8841 end Sem_Attr;