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