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