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       -- Atomic_Always_Lock_Free --
2578       -----------------------------
2579
2580       when Attribute_Atomic_Always_Lock_Free =>
2581          Check_E0;
2582          Check_Type;
2583          Set_Etype (N, Standard_Boolean);
2584
2585       ----------
2586       -- Base --
2587       ----------
2588
2589       --  Note: when the base attribute appears in the context of a subtype
2590       --  mark, the analysis is done by Sem_Ch8.Find_Type, rather than by
2591       --  the following circuit.
2592
2593       when Attribute_Base => Base : declare
2594          Typ : Entity_Id;
2595
2596       begin
2597          Check_E0;
2598          Find_Type (P);
2599          Typ := Entity (P);
2600
2601          if Ada_Version >= Ada_95
2602            and then not Is_Scalar_Type (Typ)
2603            and then not Is_Generic_Type (Typ)
2604          then
2605             Error_Attr_P ("prefix of Base attribute must be scalar type");
2606
2607          elsif Sloc (Typ) = Standard_Location
2608            and then Base_Type (Typ) = Typ
2609            and then Warn_On_Redundant_Constructs
2610          then
2611             Error_Msg_NE -- CODEFIX
2612               ("?redundant attribute, & is its own base type", N, Typ);
2613          end if;
2614
2615          if Nkind (Parent (N)) /= N_Attribute_Reference then
2616             Error_Msg_Name_1 := Aname;
2617             Check_SPARK_Restriction
2618               ("attribute% is only allowed as prefix of another attribute", P);
2619          end if;
2620
2621          Set_Etype (N, Base_Type (Entity (P)));
2622          Set_Entity (N, Base_Type (Entity (P)));
2623          Rewrite (N, New_Reference_To (Entity (N), Loc));
2624          Analyze (N);
2625       end Base;
2626
2627       ---------
2628       -- Bit --
2629       ---------
2630
2631       when Attribute_Bit => Bit :
2632       begin
2633          Check_E0;
2634
2635          if not Is_Object_Reference (P) then
2636             Error_Attr_P ("prefix for % attribute must be object");
2637
2638          --  What about the access object cases ???
2639
2640          else
2641             null;
2642          end if;
2643
2644          Set_Etype (N, Universal_Integer);
2645       end Bit;
2646
2647       ---------------
2648       -- Bit_Order --
2649       ---------------
2650
2651       when Attribute_Bit_Order => Bit_Order :
2652       begin
2653          Check_E0;
2654          Check_Type;
2655
2656          if not Is_Record_Type (P_Type) then
2657             Error_Attr_P ("prefix of % attribute must be record type");
2658          end if;
2659
2660          if Bytes_Big_Endian xor Reverse_Bit_Order (P_Type) then
2661             Rewrite (N,
2662               New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
2663          else
2664             Rewrite (N,
2665               New_Occurrence_Of (RTE (RE_Low_Order_First), Loc));
2666          end if;
2667
2668          Set_Etype (N, RTE (RE_Bit_Order));
2669          Resolve (N);
2670
2671          --  Reset incorrect indication of staticness
2672
2673          Set_Is_Static_Expression (N, False);
2674       end Bit_Order;
2675
2676       ------------------
2677       -- Bit_Position --
2678       ------------------
2679
2680       --  Note: in generated code, we can have a Bit_Position attribute
2681       --  applied to a (naked) record component (i.e. the prefix is an
2682       --  identifier that references an E_Component or E_Discriminant
2683       --  entity directly, and this is interpreted as expected by Gigi.
2684       --  The following code will not tolerate such usage, but when the
2685       --  expander creates this special case, it marks it as analyzed
2686       --  immediately and sets an appropriate type.
2687
2688       when Attribute_Bit_Position =>
2689          if Comes_From_Source (N) then
2690             Check_Component;
2691          end if;
2692
2693          Set_Etype (N, Universal_Integer);
2694
2695       ------------------
2696       -- Body_Version --
2697       ------------------
2698
2699       when Attribute_Body_Version =>
2700          Check_E0;
2701          Check_Program_Unit;
2702          Set_Etype (N, RTE (RE_Version_String));
2703
2704       --------------
2705       -- Callable --
2706       --------------
2707
2708       when Attribute_Callable =>
2709          Check_E0;
2710          Set_Etype (N, Standard_Boolean);
2711          Check_Task_Prefix;
2712
2713       ------------
2714       -- Caller --
2715       ------------
2716
2717       when Attribute_Caller => Caller : declare
2718          Ent        : Entity_Id;
2719          S          : Entity_Id;
2720
2721       begin
2722          Check_E0;
2723
2724          if Nkind_In (P, N_Identifier, N_Expanded_Name) then
2725             Ent := Entity (P);
2726
2727             if not Is_Entry (Ent) then
2728                Error_Attr ("invalid entry name", N);
2729             end if;
2730
2731          else
2732             Error_Attr ("invalid entry name", N);
2733             return;
2734          end if;
2735
2736          for J in reverse 0 .. Scope_Stack.Last loop
2737             S := Scope_Stack.Table (J).Entity;
2738
2739             if S = Scope (Ent) then
2740                Error_Attr ("Caller must appear in matching accept or body", N);
2741             elsif S = Ent then
2742                exit;
2743             end if;
2744          end loop;
2745
2746          Set_Etype (N, RTE (RO_AT_Task_Id));
2747       end Caller;
2748
2749       -------------
2750       -- Ceiling --
2751       -------------
2752
2753       when Attribute_Ceiling =>
2754          Check_Floating_Point_Type_1;
2755          Set_Etype (N, P_Base_Type);
2756          Resolve (E1, P_Base_Type);
2757
2758       -----------
2759       -- Class --
2760       -----------
2761
2762       when Attribute_Class =>
2763          Check_Restriction (No_Dispatch, N);
2764          Check_E0;
2765          Find_Type (N);
2766
2767          --  Applying Class to untagged incomplete type is obsolescent in Ada
2768          --  2005. Note that we can't test Is_Tagged_Type here on P_Type, since
2769          --  this flag gets set by Find_Type in this situation.
2770
2771          if Restriction_Check_Required (No_Obsolescent_Features)
2772            and then Ada_Version >= Ada_2005
2773            and then Ekind (P_Type) = E_Incomplete_Type
2774          then
2775             declare
2776                DN : constant Node_Id := Declaration_Node (P_Type);
2777             begin
2778                if Nkind (DN) = N_Incomplete_Type_Declaration
2779                  and then not Tagged_Present (DN)
2780                then
2781                   Check_Restriction (No_Obsolescent_Features, P);
2782                end if;
2783             end;
2784          end if;
2785
2786       ------------------
2787       -- Code_Address --
2788       ------------------
2789
2790       when Attribute_Code_Address =>
2791          Check_E0;
2792
2793          if Nkind (P) = N_Attribute_Reference
2794            and then (Attribute_Name (P) = Name_Elab_Body
2795                        or else
2796                      Attribute_Name (P) = Name_Elab_Spec)
2797          then
2798             null;
2799
2800          elsif not Is_Entity_Name (P)
2801            or else (Ekind (Entity (P)) /= E_Function
2802                       and then
2803                     Ekind (Entity (P)) /= E_Procedure)
2804          then
2805             Error_Attr ("invalid prefix for % attribute", P);
2806             Set_Address_Taken (Entity (P));
2807
2808          --  Issue an error if the prefix denotes an eliminated subprogram
2809
2810          else
2811             Check_For_Eliminated_Subprogram (P, Entity (P));
2812          end if;
2813
2814          Set_Etype (N, RTE (RE_Address));
2815
2816       ----------------------
2817       -- Compiler_Version --
2818       ----------------------
2819
2820       when Attribute_Compiler_Version =>
2821          Check_E0;
2822          Check_Standard_Prefix;
2823          Rewrite (N, Make_String_Literal (Loc, "GNAT " & Gnat_Version_String));
2824          Analyze_And_Resolve (N, Standard_String);
2825
2826       --------------------
2827       -- Component_Size --
2828       --------------------
2829
2830       when Attribute_Component_Size =>
2831          Check_E0;
2832          Set_Etype (N, Universal_Integer);
2833
2834          --  Note: unlike other array attributes, unconstrained arrays are OK
2835
2836          if Is_Array_Type (P_Type) and then not Is_Constrained (P_Type) then
2837             null;
2838          else
2839             Check_Array_Type;
2840          end if;
2841
2842       -------------
2843       -- Compose --
2844       -------------
2845
2846       when Attribute_Compose =>
2847          Check_Floating_Point_Type_2;
2848          Set_Etype (N, P_Base_Type);
2849          Resolve (E1, P_Base_Type);
2850          Resolve (E2, Any_Integer);
2851
2852       -----------------
2853       -- Constrained --
2854       -----------------
2855
2856       when Attribute_Constrained =>
2857          Check_E0;
2858          Set_Etype (N, Standard_Boolean);
2859
2860          --  Case from RM J.4(2) of constrained applied to private type
2861
2862          if Is_Entity_Name (P) and then Is_Type (Entity (P)) then
2863             Check_Restriction (No_Obsolescent_Features, P);
2864
2865             if Warn_On_Obsolescent_Feature then
2866                Error_Msg_N
2867                  ("constrained for private type is an " &
2868                   "obsolescent feature (RM J.4)?", N);
2869             end if;
2870
2871             --  If we are within an instance, the attribute must be legal
2872             --  because it was valid in the generic unit. Ditto if this is
2873             --  an inlining of a function declared in an instance.
2874
2875             if In_Instance
2876               or else In_Inlined_Body
2877             then
2878                return;
2879
2880             --  For sure OK if we have a real private type itself, but must
2881             --  be completed, cannot apply Constrained to incomplete type.
2882
2883             elsif Is_Private_Type (Entity (P)) then
2884
2885                --  Note: this is one of the Annex J features that does not
2886                --  generate a warning from -gnatwj, since in fact it seems
2887                --  very useful, and is used in the GNAT runtime.
2888
2889                Check_Not_Incomplete_Type;
2890                return;
2891             end if;
2892
2893          --  Normal (non-obsolescent case) of application to object of
2894          --  a discriminated type.
2895
2896          else
2897             Check_Object_Reference (P);
2898
2899             --  If N does not come from source, then we allow the
2900             --  the attribute prefix to be of a private type whose
2901             --  full type has discriminants. This occurs in cases
2902             --  involving expanded calls to stream attributes.
2903
2904             if not Comes_From_Source (N) then
2905                P_Type := Underlying_Type (P_Type);
2906             end if;
2907
2908             --  Must have discriminants or be an access type designating
2909             --  a type with discriminants. If it is a classwide type is ???
2910             --  has unknown discriminants.
2911
2912             if Has_Discriminants (P_Type)
2913                or else Has_Unknown_Discriminants (P_Type)
2914                or else
2915                  (Is_Access_Type (P_Type)
2916                    and then Has_Discriminants (Designated_Type (P_Type)))
2917             then
2918                return;
2919
2920             --  Also allow an object of a generic type if extensions allowed
2921             --  and allow this for any type at all.
2922
2923             elsif (Is_Generic_Type (P_Type)
2924                      or else Is_Generic_Actual_Type (P_Type))
2925               and then Extensions_Allowed
2926             then
2927                return;
2928             end if;
2929          end if;
2930
2931          --  Fall through if bad prefix
2932
2933          Error_Attr_P
2934            ("prefix of % attribute must be object of discriminated type");
2935
2936       ---------------
2937       -- Copy_Sign --
2938       ---------------
2939
2940       when Attribute_Copy_Sign =>
2941          Check_Floating_Point_Type_2;
2942          Set_Etype (N, P_Base_Type);
2943          Resolve (E1, P_Base_Type);
2944          Resolve (E2, P_Base_Type);
2945
2946       -----------
2947       -- Count --
2948       -----------
2949
2950       when Attribute_Count => Count :
2951       declare
2952          Ent : Entity_Id;
2953          S   : Entity_Id;
2954          Tsk : Entity_Id;
2955
2956       begin
2957          Check_E0;
2958
2959          if Nkind_In (P, N_Identifier, N_Expanded_Name) then
2960             Ent := Entity (P);
2961
2962             if Ekind (Ent) /= E_Entry then
2963                Error_Attr ("invalid entry name", N);
2964             end if;
2965
2966          elsif Nkind (P) = N_Indexed_Component then
2967             if not Is_Entity_Name (Prefix (P))
2968               or else  No (Entity (Prefix (P)))
2969               or else Ekind (Entity (Prefix (P))) /= E_Entry_Family
2970             then
2971                if Nkind (Prefix (P)) = N_Selected_Component
2972                  and then Present (Entity (Selector_Name (Prefix (P))))
2973                  and then Ekind (Entity (Selector_Name (Prefix (P)))) =
2974                                                              E_Entry_Family
2975                then
2976                   Error_Attr
2977                     ("attribute % must apply to entry of current task", P);
2978
2979                else
2980                   Error_Attr ("invalid entry family name", P);
2981                end if;
2982                return;
2983
2984             else
2985                Ent := Entity (Prefix (P));
2986             end if;
2987
2988          elsif Nkind (P) = N_Selected_Component
2989            and then Present (Entity (Selector_Name (P)))
2990            and then Ekind (Entity (Selector_Name (P))) = E_Entry
2991          then
2992             Error_Attr
2993               ("attribute % must apply to entry of current task", P);
2994
2995          else
2996             Error_Attr ("invalid entry name", N);
2997             return;
2998          end if;
2999
3000          for J in reverse 0 .. Scope_Stack.Last loop
3001             S := Scope_Stack.Table (J).Entity;
3002
3003             if S = Scope (Ent) then
3004                if Nkind (P) = N_Expanded_Name then
3005                   Tsk := Entity (Prefix (P));
3006
3007                   --  The prefix denotes either the task type, or else a
3008                   --  single task whose task type is being analyzed.
3009
3010                   if (Is_Type (Tsk)
3011                       and then Tsk = S)
3012
3013                     or else (not Is_Type (Tsk)
3014                       and then Etype (Tsk) = S
3015                       and then not (Comes_From_Source (S)))
3016                   then
3017                      null;
3018                   else
3019                      Error_Attr
3020                        ("Attribute % must apply to entry of current task", N);
3021                   end if;
3022                end if;
3023
3024                exit;
3025
3026             elsif Ekind (Scope (Ent)) in Task_Kind
3027               and then
3028                 not Ekind_In (S, E_Loop, E_Block, E_Entry, E_Entry_Family)
3029             then
3030                Error_Attr ("Attribute % cannot appear in inner unit", N);
3031
3032             elsif Ekind (Scope (Ent)) = E_Protected_Type
3033               and then not Has_Completion (Scope (Ent))
3034             then
3035                Error_Attr ("attribute % can only be used inside body", N);
3036             end if;
3037          end loop;
3038
3039          if Is_Overloaded (P) then
3040             declare
3041                Index : Interp_Index;
3042                It    : Interp;
3043
3044             begin
3045                Get_First_Interp (P, Index, It);
3046
3047                while Present (It.Nam) loop
3048                   if It.Nam = Ent then
3049                      null;
3050
3051                   --  Ada 2005 (AI-345): Do not consider primitive entry
3052                   --  wrappers generated for task or protected types.
3053
3054                   elsif Ada_Version >= Ada_2005
3055                     and then not Comes_From_Source (It.Nam)
3056                   then
3057                      null;
3058
3059                   else
3060                      Error_Attr ("ambiguous entry name", N);
3061                   end if;
3062
3063                   Get_Next_Interp (Index, It);
3064                end loop;
3065             end;
3066          end if;
3067
3068          Set_Etype (N, Universal_Integer);
3069       end Count;
3070
3071       -----------------------
3072       -- Default_Bit_Order --
3073       -----------------------
3074
3075       when Attribute_Default_Bit_Order => Default_Bit_Order :
3076       begin
3077          Check_Standard_Prefix;
3078
3079          if Bytes_Big_Endian then
3080             Rewrite (N,
3081               Make_Integer_Literal (Loc, False_Value));
3082          else
3083             Rewrite (N,
3084               Make_Integer_Literal (Loc, True_Value));
3085          end if;
3086
3087          Set_Etype (N, Universal_Integer);
3088          Set_Is_Static_Expression (N);
3089       end Default_Bit_Order;
3090
3091       --------------
3092       -- Definite --
3093       --------------
3094
3095       when Attribute_Definite =>
3096          Legal_Formal_Attribute;
3097
3098       -----------
3099       -- Delta --
3100       -----------
3101
3102       when Attribute_Delta =>
3103          Check_Fixed_Point_Type_0;
3104          Set_Etype (N, Universal_Real);
3105
3106       ------------
3107       -- Denorm --
3108       ------------
3109
3110       when Attribute_Denorm =>
3111          Check_Floating_Point_Type_0;
3112          Set_Etype (N, Standard_Boolean);
3113
3114       ---------------------
3115       -- Descriptor_Size --
3116       ---------------------
3117
3118       when Attribute_Descriptor_Size =>
3119          Check_E0;
3120
3121          if not Is_Entity_Name (P)
3122            or else not Is_Type (Entity (P))
3123          then
3124             Error_Attr_P ("prefix of attribute % must denote a type");
3125          end if;
3126
3127          Set_Etype (N, Universal_Integer);
3128
3129       ------------
3130       -- Digits --
3131       ------------
3132
3133       when Attribute_Digits =>
3134          Check_E0;
3135          Check_Type;
3136
3137          if not Is_Floating_Point_Type (P_Type)
3138            and then not Is_Decimal_Fixed_Point_Type (P_Type)
3139          then
3140             Error_Attr_P
3141               ("prefix of % attribute must be float or decimal type");
3142          end if;
3143
3144          Set_Etype (N, Universal_Integer);
3145
3146       ---------------
3147       -- Elab_Body --
3148       ---------------
3149
3150       --  Also handles processing for Elab_Spec and Elab_Subp_Body
3151
3152       when Attribute_Elab_Body      |
3153            Attribute_Elab_Spec      |
3154            Attribute_Elab_Subp_Body =>
3155
3156          Check_E0;
3157          Check_Unit_Name (P);
3158          Set_Etype (N, Standard_Void_Type);
3159
3160          --  We have to manually call the expander in this case to get
3161          --  the necessary expansion (normally attributes that return
3162          --  entities are not expanded).
3163
3164          Expand (N);
3165
3166       ---------------
3167       -- Elab_Spec --
3168       ---------------
3169
3170       --  Shares processing with Elab_Body
3171
3172       ----------------
3173       -- Elaborated --
3174       ----------------
3175
3176       when Attribute_Elaborated =>
3177          Check_E0;
3178          Check_Unit_Name (P);
3179          Set_Etype (N, Standard_Boolean);
3180
3181       ----------
3182       -- Emax --
3183       ----------
3184
3185       when Attribute_Emax =>
3186          Check_Floating_Point_Type_0;
3187          Set_Etype (N, Universal_Integer);
3188
3189       -------------
3190       -- Enabled --
3191       -------------
3192
3193       when Attribute_Enabled =>
3194          Check_Either_E0_Or_E1;
3195
3196          if Present (E1) then
3197             if not Is_Entity_Name (E1) or else No (Entity (E1)) then
3198                Error_Msg_N ("entity name expected for Enabled attribute", E1);
3199                E1 := Empty;
3200             end if;
3201          end if;
3202
3203          if Nkind (P) /= N_Identifier then
3204             Error_Msg_N ("identifier expected (check name)", P);
3205          elsif Get_Check_Id (Chars (P)) = No_Check_Id then
3206             Error_Msg_N ("& is not a recognized check name", P);
3207          end if;
3208
3209          Set_Etype (N, Standard_Boolean);
3210
3211       --------------
3212       -- Enum_Rep --
3213       --------------
3214
3215       when Attribute_Enum_Rep => Enum_Rep : declare
3216       begin
3217          if Present (E1) then
3218             Check_E1;
3219             Check_Discrete_Type;
3220             Resolve (E1, P_Base_Type);
3221
3222          else
3223             if not Is_Entity_Name (P)
3224               or else (not Is_Object (Entity (P))
3225                          and then
3226                        Ekind (Entity (P)) /= E_Enumeration_Literal)
3227             then
3228                Error_Attr_P
3229                  ("prefix of % attribute must be " &
3230                   "discrete type/object or enum literal");
3231             end if;
3232          end if;
3233
3234          Set_Etype (N, Universal_Integer);
3235       end Enum_Rep;
3236
3237       --------------
3238       -- Enum_Val --
3239       --------------
3240
3241       when Attribute_Enum_Val => Enum_Val : begin
3242          Check_E1;
3243          Check_Type;
3244
3245          if not Is_Enumeration_Type (P_Type) then
3246             Error_Attr_P ("prefix of % attribute must be enumeration type");
3247          end if;
3248
3249          --  If the enumeration type has a standard representation, the effect
3250          --  is the same as 'Val, so rewrite the attribute as a 'Val.
3251
3252          if not Has_Non_Standard_Rep (P_Base_Type) then
3253             Rewrite (N,
3254               Make_Attribute_Reference (Loc,
3255                 Prefix         => Relocate_Node (Prefix (N)),
3256                 Attribute_Name => Name_Val,
3257                 Expressions    => New_List (Relocate_Node (E1))));
3258             Analyze_And_Resolve (N, P_Base_Type);
3259
3260          --  Non-standard representation case (enumeration with holes)
3261
3262          else
3263             Check_Enum_Image;
3264             Resolve (E1, Any_Integer);
3265             Set_Etype (N, P_Base_Type);
3266          end if;
3267       end Enum_Val;
3268
3269       -------------
3270       -- Epsilon --
3271       -------------
3272
3273       when Attribute_Epsilon =>
3274          Check_Floating_Point_Type_0;
3275          Set_Etype (N, Universal_Real);
3276
3277       --------------
3278       -- Exponent --
3279       --------------
3280
3281       when Attribute_Exponent =>
3282          Check_Floating_Point_Type_1;
3283          Set_Etype (N, Universal_Integer);
3284          Resolve (E1, P_Base_Type);
3285
3286       ------------------
3287       -- External_Tag --
3288       ------------------
3289
3290       when Attribute_External_Tag =>
3291          Check_E0;
3292          Check_Type;
3293
3294          Set_Etype (N, Standard_String);
3295
3296          if not Is_Tagged_Type (P_Type) then
3297             Error_Attr_P ("prefix of % attribute must be tagged");
3298          end if;
3299
3300       ---------------
3301       -- Fast_Math --
3302       ---------------
3303
3304       when Attribute_Fast_Math =>
3305          Check_Standard_Prefix;
3306          Rewrite (N, New_Occurrence_Of (Boolean_Literals (Fast_Math), Loc));
3307
3308       -----------
3309       -- First --
3310       -----------
3311
3312       when Attribute_First =>
3313          Check_Array_Or_Scalar_Type;
3314          Bad_Attribute_For_Predicate;
3315
3316       ---------------
3317       -- First_Bit --
3318       ---------------
3319
3320       when Attribute_First_Bit =>
3321          Check_Component;
3322          Set_Etype (N, Universal_Integer);
3323
3324       -----------------
3325       -- First_Valid --
3326       -----------------
3327
3328       when Attribute_First_Valid =>
3329          Check_First_Last_Valid;
3330          Set_Etype (N, P_Type);
3331
3332       -----------------
3333       -- Fixed_Value --
3334       -----------------
3335
3336       when Attribute_Fixed_Value =>
3337          Check_E1;
3338          Check_Fixed_Point_Type;
3339          Resolve (E1, Any_Integer);
3340          Set_Etype (N, P_Base_Type);
3341
3342       -----------
3343       -- Floor --
3344       -----------
3345
3346       when Attribute_Floor =>
3347          Check_Floating_Point_Type_1;
3348          Set_Etype (N, P_Base_Type);
3349          Resolve (E1, P_Base_Type);
3350
3351       ----------
3352       -- Fore --
3353       ----------
3354
3355       when Attribute_Fore =>
3356          Check_Fixed_Point_Type_0;
3357          Set_Etype (N, Universal_Integer);
3358
3359       --------------
3360       -- Fraction --
3361       --------------
3362
3363       when Attribute_Fraction =>
3364          Check_Floating_Point_Type_1;
3365          Set_Etype (N, P_Base_Type);
3366          Resolve (E1, P_Base_Type);
3367
3368       --------------
3369       -- From_Any --
3370       --------------
3371
3372       when Attribute_From_Any =>
3373          Check_E1;
3374          Check_PolyORB_Attribute;
3375          Set_Etype (N, P_Base_Type);
3376
3377       -----------------------
3378       -- Has_Access_Values --
3379       -----------------------
3380
3381       when Attribute_Has_Access_Values =>
3382          Check_Type;
3383          Check_E0;
3384          Set_Etype (N, Standard_Boolean);
3385
3386       -----------------------
3387       -- Has_Tagged_Values --
3388       -----------------------
3389
3390       when Attribute_Has_Tagged_Values =>
3391          Check_Type;
3392          Check_E0;
3393          Set_Etype (N, Standard_Boolean);
3394
3395       -----------------------
3396       -- Has_Discriminants --
3397       -----------------------
3398
3399       when Attribute_Has_Discriminants =>
3400          Legal_Formal_Attribute;
3401
3402       --------------
3403       -- Identity --
3404       --------------
3405
3406       when Attribute_Identity =>
3407          Check_E0;
3408          Analyze (P);
3409
3410          if Etype (P) =  Standard_Exception_Type then
3411             Set_Etype (N, RTE (RE_Exception_Id));
3412
3413          --  Ada 2005 (AI-345): Attribute 'Identity may be applied to
3414          --  task interface class-wide types.
3415
3416          elsif Is_Task_Type (Etype (P))
3417            or else (Is_Access_Type (Etype (P))
3418                       and then Is_Task_Type (Designated_Type (Etype (P))))
3419            or else (Ada_Version >= Ada_2005
3420                       and then Ekind (Etype (P)) = E_Class_Wide_Type
3421                       and then Is_Interface (Etype (P))
3422                       and then Is_Task_Interface (Etype (P)))
3423          then
3424             Resolve (P);
3425             Set_Etype (N, RTE (RO_AT_Task_Id));
3426
3427          else
3428             if Ada_Version >= Ada_2005 then
3429                Error_Attr_P
3430                  ("prefix of % attribute must be an exception, a " &
3431                   "task or a task interface class-wide object");
3432             else
3433                Error_Attr_P
3434                  ("prefix of % attribute must be a task or an exception");
3435             end if;
3436          end if;
3437
3438       -----------
3439       -- Image --
3440       -----------
3441
3442       when Attribute_Image => Image :
3443       begin
3444          Check_SPARK_Restriction_On_Attribute;
3445          Check_Scalar_Type;
3446          Set_Etype (N, Standard_String);
3447
3448          if Is_Real_Type (P_Type) then
3449             if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3450                Error_Msg_Name_1 := Aname;
3451                Error_Msg_N
3452                  ("(Ada 83) % attribute not allowed for real types", N);
3453             end if;
3454          end if;
3455
3456          if Is_Enumeration_Type (P_Type) then
3457             Check_Restriction (No_Enumeration_Maps, N);
3458          end if;
3459
3460          Check_E1;
3461          Resolve (E1, P_Base_Type);
3462          Check_Enum_Image;
3463          Validate_Non_Static_Attribute_Function_Call;
3464       end Image;
3465
3466       ---------
3467       -- Img --
3468       ---------
3469
3470       when Attribute_Img => Img :
3471       begin
3472          Check_E0;
3473          Set_Etype (N, Standard_String);
3474
3475          if not Is_Scalar_Type (P_Type)
3476            or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
3477          then
3478             Error_Attr_P
3479               ("prefix of % attribute must be scalar object name");
3480          end if;
3481
3482          Check_Enum_Image;
3483       end Img;
3484
3485       -----------
3486       -- Input --
3487       -----------
3488
3489       when Attribute_Input =>
3490          Check_E1;
3491          Check_Stream_Attribute (TSS_Stream_Input);
3492          Set_Etype (N, P_Base_Type);
3493
3494       -------------------
3495       -- Integer_Value --
3496       -------------------
3497
3498       when Attribute_Integer_Value =>
3499          Check_E1;
3500          Check_Integer_Type;
3501          Resolve (E1, Any_Fixed);
3502
3503          --  Signal an error if argument type is not a specific fixed-point
3504          --  subtype. An error has been signalled already if the argument
3505          --  was not of a fixed-point type.
3506
3507          if Etype (E1) = Any_Fixed and then not Error_Posted (E1) then
3508             Error_Attr ("argument of % must be of a fixed-point type", E1);
3509          end if;
3510
3511          Set_Etype (N, P_Base_Type);
3512
3513       -------------------
3514       -- Invalid_Value --
3515       -------------------
3516
3517       when Attribute_Invalid_Value =>
3518          Check_E0;
3519          Check_Scalar_Type;
3520          Set_Etype (N, P_Base_Type);
3521          Invalid_Value_Used := True;
3522
3523       -----------
3524       -- Large --
3525       -----------
3526
3527       when Attribute_Large =>
3528          Check_E0;
3529          Check_Real_Type;
3530          Set_Etype (N, Universal_Real);
3531
3532       ----------
3533       -- Last --
3534       ----------
3535
3536       when Attribute_Last =>
3537          Check_Array_Or_Scalar_Type;
3538          Bad_Attribute_For_Predicate;
3539
3540       --------------
3541       -- Last_Bit --
3542       --------------
3543
3544       when Attribute_Last_Bit =>
3545          Check_Component;
3546          Set_Etype (N, Universal_Integer);
3547
3548       ----------------
3549       -- Last_Valid --
3550       ----------------
3551
3552       when Attribute_Last_Valid =>
3553          Check_First_Last_Valid;
3554          Set_Etype (N, P_Type);
3555
3556       ------------------
3557       -- Leading_Part --
3558       ------------------
3559
3560       when Attribute_Leading_Part =>
3561          Check_Floating_Point_Type_2;
3562          Set_Etype (N, P_Base_Type);
3563          Resolve (E1, P_Base_Type);
3564          Resolve (E2, Any_Integer);
3565
3566       ------------
3567       -- Length --
3568       ------------
3569
3570       when Attribute_Length =>
3571          Check_Array_Type;
3572          Set_Etype (N, Universal_Integer);
3573
3574       ---------------
3575       -- Lock_Free --
3576       ---------------
3577
3578       when Attribute_Lock_Free =>
3579          Check_E0;
3580          Set_Etype (N, Standard_Boolean);
3581
3582          if not Is_Protected_Type (P_Type) then
3583             Error_Attr_P
3584               ("prefix of % attribute must be a protected object");
3585          end if;
3586
3587       -------------
3588       -- Machine --
3589       -------------
3590
3591       when Attribute_Machine =>
3592          Check_Floating_Point_Type_1;
3593          Set_Etype (N, P_Base_Type);
3594          Resolve (E1, P_Base_Type);
3595
3596       ------------------
3597       -- Machine_Emax --
3598       ------------------
3599
3600       when Attribute_Machine_Emax =>
3601          Check_Floating_Point_Type_0;
3602          Set_Etype (N, Universal_Integer);
3603
3604       ------------------
3605       -- Machine_Emin --
3606       ------------------
3607
3608       when Attribute_Machine_Emin =>
3609          Check_Floating_Point_Type_0;
3610          Set_Etype (N, Universal_Integer);
3611
3612       ----------------------
3613       -- Machine_Mantissa --
3614       ----------------------
3615
3616       when Attribute_Machine_Mantissa =>
3617          Check_Floating_Point_Type_0;
3618          Set_Etype (N, Universal_Integer);
3619
3620       -----------------------
3621       -- Machine_Overflows --
3622       -----------------------
3623
3624       when Attribute_Machine_Overflows =>
3625          Check_Real_Type;
3626          Check_E0;
3627          Set_Etype (N, Standard_Boolean);
3628
3629       -------------------
3630       -- Machine_Radix --
3631       -------------------
3632
3633       when Attribute_Machine_Radix =>
3634          Check_Real_Type;
3635          Check_E0;
3636          Set_Etype (N, Universal_Integer);
3637
3638       ----------------------
3639       -- Machine_Rounding --
3640       ----------------------
3641
3642       when Attribute_Machine_Rounding =>
3643          Check_Floating_Point_Type_1;
3644          Set_Etype (N, P_Base_Type);
3645          Resolve (E1, P_Base_Type);
3646
3647       --------------------
3648       -- Machine_Rounds --
3649       --------------------
3650
3651       when Attribute_Machine_Rounds =>
3652          Check_Real_Type;
3653          Check_E0;
3654          Set_Etype (N, Standard_Boolean);
3655
3656       ------------------
3657       -- Machine_Size --
3658       ------------------
3659
3660       when Attribute_Machine_Size =>
3661          Check_E0;
3662          Check_Type;
3663          Check_Not_Incomplete_Type;
3664          Set_Etype (N, Universal_Integer);
3665
3666       --------------
3667       -- Mantissa --
3668       --------------
3669
3670       when Attribute_Mantissa =>
3671          Check_E0;
3672          Check_Real_Type;
3673          Set_Etype (N, Universal_Integer);
3674
3675       ---------
3676       -- Max --
3677       ---------
3678
3679       when Attribute_Max =>
3680          Check_E2;
3681          Check_Scalar_Type;
3682          Resolve (E1, P_Base_Type);
3683          Resolve (E2, P_Base_Type);
3684          Set_Etype (N, P_Base_Type);
3685
3686       ----------------------------------
3687       -- Max_Alignment_For_Allocation --
3688       -- Max_Size_In_Storage_Elements --
3689       ----------------------------------
3690
3691       when Attribute_Max_Alignment_For_Allocation |
3692         Attribute_Max_Size_In_Storage_Elements =>
3693          Check_E0;
3694          Check_Type;
3695          Check_Not_Incomplete_Type;
3696          Set_Etype (N, Universal_Integer);
3697
3698       -----------------------
3699       -- Maximum_Alignment --
3700       -----------------------
3701
3702       when Attribute_Maximum_Alignment =>
3703          Standard_Attribute (Ttypes.Maximum_Alignment);
3704
3705       --------------------
3706       -- Mechanism_Code --
3707       --------------------
3708
3709       when Attribute_Mechanism_Code =>
3710          if not Is_Entity_Name (P)
3711            or else not Is_Subprogram (Entity (P))
3712          then
3713             Error_Attr_P ("prefix of % attribute must be subprogram");
3714          end if;
3715
3716          Check_Either_E0_Or_E1;
3717
3718          if Present (E1) then
3719             Resolve (E1, Any_Integer);
3720             Set_Etype (E1, Standard_Integer);
3721
3722             if not Is_Static_Expression (E1) then
3723                Flag_Non_Static_Expr
3724                  ("expression for parameter number must be static!", E1);
3725                Error_Attr;
3726
3727             elsif UI_To_Int (Intval (E1)) > Number_Formals (Entity (P))
3728               or else UI_To_Int (Intval (E1)) < 0
3729             then
3730                Error_Attr ("invalid parameter number for % attribute", E1);
3731             end if;
3732          end if;
3733
3734          Set_Etype (N, Universal_Integer);
3735
3736       ---------
3737       -- Min --
3738       ---------
3739
3740       when Attribute_Min =>
3741          Check_E2;
3742          Check_Scalar_Type;
3743          Resolve (E1, P_Base_Type);
3744          Resolve (E2, P_Base_Type);
3745          Set_Etype (N, P_Base_Type);
3746
3747       ---------
3748       -- Mod --
3749       ---------
3750
3751       when Attribute_Mod =>
3752
3753          --  Note: this attribute is only allowed in Ada 2005 mode, but
3754          --  we do not need to test that here, since Mod is only recognized
3755          --  as an attribute name in Ada 2005 mode during the parse.
3756
3757          Check_E1;
3758          Check_Modular_Integer_Type;
3759          Resolve (E1, Any_Integer);
3760          Set_Etype (N, P_Base_Type);
3761
3762       -----------
3763       -- Model --
3764       -----------
3765
3766       when Attribute_Model =>
3767          Check_Floating_Point_Type_1;
3768          Set_Etype (N, P_Base_Type);
3769          Resolve (E1, P_Base_Type);
3770
3771       ----------------
3772       -- Model_Emin --
3773       ----------------
3774
3775       when Attribute_Model_Emin =>
3776          Check_Floating_Point_Type_0;
3777          Set_Etype (N, Universal_Integer);
3778
3779       -------------------
3780       -- Model_Epsilon --
3781       -------------------
3782
3783       when Attribute_Model_Epsilon =>
3784          Check_Floating_Point_Type_0;
3785          Set_Etype (N, Universal_Real);
3786
3787       --------------------
3788       -- Model_Mantissa --
3789       --------------------
3790
3791       when Attribute_Model_Mantissa =>
3792          Check_Floating_Point_Type_0;
3793          Set_Etype (N, Universal_Integer);
3794
3795       -----------------
3796       -- Model_Small --
3797       -----------------
3798
3799       when Attribute_Model_Small =>
3800          Check_Floating_Point_Type_0;
3801          Set_Etype (N, Universal_Real);
3802
3803       -------------
3804       -- Modulus --
3805       -------------
3806
3807       when Attribute_Modulus =>
3808          Check_E0;
3809          Check_Modular_Integer_Type;
3810          Set_Etype (N, Universal_Integer);
3811
3812       --------------------
3813       -- Null_Parameter --
3814       --------------------
3815
3816       when Attribute_Null_Parameter => Null_Parameter : declare
3817          Parnt  : constant Node_Id := Parent (N);
3818          GParnt : constant Node_Id := Parent (Parnt);
3819
3820          procedure Bad_Null_Parameter (Msg : String);
3821          --  Used if bad Null parameter attribute node is found. Issues
3822          --  given error message, and also sets the type to Any_Type to
3823          --  avoid blowups later on from dealing with a junk node.
3824
3825          procedure Must_Be_Imported (Proc_Ent : Entity_Id);
3826          --  Called to check that Proc_Ent is imported subprogram
3827
3828          ------------------------
3829          -- Bad_Null_Parameter --
3830          ------------------------
3831
3832          procedure Bad_Null_Parameter (Msg : String) is
3833          begin
3834             Error_Msg_N (Msg, N);
3835             Set_Etype (N, Any_Type);
3836          end Bad_Null_Parameter;
3837
3838          ----------------------
3839          -- Must_Be_Imported --
3840          ----------------------
3841
3842          procedure Must_Be_Imported (Proc_Ent : Entity_Id) is
3843             Pent : constant Entity_Id := Ultimate_Alias (Proc_Ent);
3844
3845          begin
3846             --  Ignore check if procedure not frozen yet (we will get
3847             --  another chance when the default parameter is reanalyzed)
3848
3849             if not Is_Frozen (Pent) then
3850                return;
3851
3852             elsif not Is_Imported (Pent) then
3853                Bad_Null_Parameter
3854                  ("Null_Parameter can only be used with imported subprogram");
3855
3856             else
3857                return;
3858             end if;
3859          end Must_Be_Imported;
3860
3861       --  Start of processing for Null_Parameter
3862
3863       begin
3864          Check_Type;
3865          Check_E0;
3866          Set_Etype (N, P_Type);
3867
3868          --  Case of attribute used as default expression
3869
3870          if Nkind (Parnt) = N_Parameter_Specification then
3871             Must_Be_Imported (Defining_Entity (GParnt));
3872
3873          --  Case of attribute used as actual for subprogram (positional)
3874
3875          elsif Nkind (Parnt) in N_Subprogram_Call
3876             and then Is_Entity_Name (Name (Parnt))
3877          then
3878             Must_Be_Imported (Entity (Name (Parnt)));
3879
3880          --  Case of attribute used as actual for subprogram (named)
3881
3882          elsif Nkind (Parnt) = N_Parameter_Association
3883            and then Nkind (GParnt) in N_Subprogram_Call
3884            and then Is_Entity_Name (Name (GParnt))
3885          then
3886             Must_Be_Imported (Entity (Name (GParnt)));
3887
3888          --  Not an allowed case
3889
3890          else
3891             Bad_Null_Parameter
3892               ("Null_Parameter must be actual or default parameter");
3893          end if;
3894       end Null_Parameter;
3895
3896       -----------------
3897       -- Object_Size --
3898       -----------------
3899
3900       when Attribute_Object_Size =>
3901          Check_E0;
3902          Check_Type;
3903          Check_Not_Incomplete_Type;
3904          Set_Etype (N, Universal_Integer);
3905
3906       ---------
3907       -- Old --
3908       ---------
3909
3910       when Attribute_Old => Old : declare
3911          CS : Entity_Id;
3912          --  The enclosing scope, excluding loops for quantified expressions.
3913          --  During analysis, it is the postcondition subprogram. During
3914          --  pre-analysis, it is the scope of the subprogram declaration.
3915
3916          Prag : Node_Id;
3917          --  During pre-analysis, Prag is the enclosing pragma node if any
3918
3919       begin
3920          --  Find enclosing scopes, excluding loops
3921
3922          CS := Current_Scope;
3923          while Ekind (CS) = E_Loop loop
3924             CS := Scope (CS);
3925          end loop;
3926
3927          --  If we are in Spec_Expression mode, this should be the prescan of
3928          --  the postcondition (or contract case, or test case) pragma.
3929
3930          if In_Spec_Expression then
3931
3932             --  Check in postcondition or Ensures clause
3933
3934             Prag := N;
3935             while not Nkind_In (Prag, N_Pragma,
3936                                 N_Function_Specification,
3937                                 N_Procedure_Specification,
3938                                 N_Subprogram_Body)
3939             loop
3940                Prag := Parent (Prag);
3941             end loop;
3942
3943             if Nkind (Prag) /= N_Pragma then
3944                Error_Attr ("% attribute can only appear in postcondition", P);
3945
3946             elsif Get_Pragma_Id (Prag) = Pragma_Contract_Case
3947                     or else
3948                   Get_Pragma_Id (Prag) = Pragma_Test_Case
3949             then
3950                declare
3951                   Arg_Ens : constant Node_Id :=
3952                               Get_Ensures_From_CTC_Pragma (Prag);
3953                   Arg     : Node_Id;
3954
3955                begin
3956                   Arg := N;
3957                   while Arg /= Prag and Arg /= Arg_Ens loop
3958                      Arg := Parent (Arg);
3959                   end loop;
3960
3961                   if Arg /= Arg_Ens then
3962                      if Get_Pragma_Id (Prag) = Pragma_Contract_Case then
3963                         Error_Attr
3964                           ("% attribute misplaced inside contract case", P);
3965                      else
3966                         Error_Attr
3967                           ("% attribute misplaced inside test case", P);
3968                      end if;
3969                   end if;
3970                end;
3971
3972             elsif Get_Pragma_Id (Prag) /= Pragma_Postcondition then
3973                Error_Attr ("% attribute can only appear in postcondition", P);
3974             end if;
3975
3976          --  Body case, where we must be inside a generated _Postcondition
3977          --  procedure, or else the attribute use is definitely misplaced. The
3978          --  postcondition itself may have generated transient scopes, and is
3979          --  not necessarily the current one.
3980
3981          else
3982             while Present (CS) and then CS /= Standard_Standard loop
3983                if Chars (CS) = Name_uPostconditions then
3984                   exit;
3985                else
3986                   CS := Scope (CS);
3987                end if;
3988             end loop;
3989
3990             if Chars (CS) /= Name_uPostconditions then
3991                Error_Attr ("% attribute can only appear in postcondition", P);
3992             end if;
3993          end if;
3994
3995          --  Either the attribute reference is generated for a Requires
3996          --  clause, in which case no expressions follow, or it is a
3997          --  primary. In that case, if expressions follow, the attribute
3998          --  reference is an indexable object, so rewrite the node
3999          --  accordingly.
4000
4001          if Present (E1) then
4002             Rewrite (N,
4003               Make_Indexed_Component (Loc,
4004                 Prefix      =>
4005                   Make_Attribute_Reference (Loc,
4006                     Prefix         => Relocate_Node (Prefix (N)),
4007                     Attribute_Name => Name_Old),
4008                 Expressions => Expressions (N)));
4009
4010             Analyze (N);
4011             return;
4012          end if;
4013
4014          Check_E0;
4015
4016          --  Prefix has not been analyzed yet, and its full analysis will
4017          --  take place during expansion (see below).
4018
4019          Preanalyze_And_Resolve (P);
4020          P_Type := Etype (P);
4021          Set_Etype (N, P_Type);
4022
4023          if Is_Limited_Type (P_Type) then
4024             Error_Attr ("attribute % cannot apply to limited objects", P);
4025          end if;
4026
4027          if Is_Entity_Name (P)
4028            and then Is_Constant_Object (Entity (P))
4029          then
4030             Error_Msg_N
4031               ("?attribute Old applied to constant has no effect", P);
4032          end if;
4033
4034          --  The attribute appears within a pre/postcondition, but refers to
4035          --  an entity in the enclosing subprogram. If it is a component of
4036          --  a formal its expansion might generate actual subtypes that may
4037          --  be referenced in an inner context, and which must be elaborated
4038          --  within the subprogram itself. If the prefix includes a function
4039          --  call it may involve finalization actions that should only be
4040          --  inserted when the attribute has been rewritten as a declarations.
4041          --  As a result, if the prefix is not a simple name we create
4042          --  a declaration for it now, and insert it at the start of the
4043          --  enclosing subprogram. This is properly an expansion activity
4044          --  but it has to be performed now to prevent out-of-order issues.
4045
4046          --  This expansion is both harmful and not needed in Alfa mode, since
4047          --  the formal verification backend relies on the types of nodes
4048          --  (hence is not robust w.r.t. a change to base type here), and does
4049          --  not suffer from the out-of-order issue described above. Thus, this
4050          --  expansion is skipped in Alfa mode.
4051
4052          if not Is_Entity_Name (P) and then not Alfa_Mode then
4053             P_Type := Base_Type (P_Type);
4054             Set_Etype (N, P_Type);
4055             Set_Etype (P, P_Type);
4056             Expand (N);
4057          end if;
4058       end Old;
4059
4060       ----------------------
4061       -- Overlaps_Storage --
4062       ----------------------
4063
4064       when Attribute_Overlaps_Storage =>
4065          Check_Ada_2012_Attribute;
4066          Check_E1;
4067
4068          --  Both arguments must be objects of any type
4069
4070          Analyze_And_Resolve (P);
4071          Analyze_And_Resolve (E1);
4072          Check_Object_Reference (P);
4073          Check_Object_Reference (E1);
4074          Set_Etype (N, Standard_Boolean);
4075
4076       ------------
4077       -- Output --
4078       ------------
4079
4080       when Attribute_Output =>
4081          Check_E2;
4082          Check_Stream_Attribute (TSS_Stream_Output);
4083          Set_Etype (N, Standard_Void_Type);
4084          Resolve (N, Standard_Void_Type);
4085
4086       ------------------
4087       -- Partition_ID --
4088       ------------------
4089
4090       when Attribute_Partition_ID => Partition_Id :
4091       begin
4092          Check_E0;
4093
4094          if P_Type /= Any_Type then
4095             if not Is_Library_Level_Entity (Entity (P)) then
4096                Error_Attr_P
4097                  ("prefix of % attribute must be library-level entity");
4098
4099             --  The defining entity of prefix should not be declared inside a
4100             --  Pure unit. RM E.1(8). Is_Pure was set during declaration.
4101
4102             elsif Is_Entity_Name (P)
4103               and then Is_Pure (Entity (P))
4104             then
4105                Error_Attr_P ("prefix of% attribute must not be declared pure");
4106             end if;
4107          end if;
4108
4109          Set_Etype (N, Universal_Integer);
4110       end Partition_Id;
4111
4112       -------------------------
4113       -- Passed_By_Reference --
4114       -------------------------
4115
4116       when Attribute_Passed_By_Reference =>
4117          Check_E0;
4118          Check_Type;
4119          Set_Etype (N, Standard_Boolean);
4120
4121       ------------------
4122       -- Pool_Address --
4123       ------------------
4124
4125       when Attribute_Pool_Address =>
4126          Check_E0;
4127          Set_Etype (N, RTE (RE_Address));
4128
4129       ---------
4130       -- Pos --
4131       ---------
4132
4133       when Attribute_Pos =>
4134          Check_Discrete_Type;
4135          Check_E1;
4136
4137          if Is_Boolean_Type (P_Type) then
4138             Error_Msg_Name_1 := Aname;
4139             Error_Msg_Name_2 := Chars (P_Type);
4140             Check_SPARK_Restriction
4141               ("attribute% is not allowed for type%", P);
4142          end if;
4143
4144          Resolve (E1, P_Base_Type);
4145          Set_Etype (N, Universal_Integer);
4146
4147       --------------
4148       -- Position --
4149       --------------
4150
4151       when Attribute_Position =>
4152          Check_Component;
4153          Set_Etype (N, Universal_Integer);
4154
4155       ----------
4156       -- Pred --
4157       ----------
4158
4159       when Attribute_Pred =>
4160          Check_Scalar_Type;
4161          Check_E1;
4162
4163          if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then
4164             Error_Msg_Name_1 := Aname;
4165             Error_Msg_Name_2 := Chars (P_Type);
4166             Check_SPARK_Restriction
4167               ("attribute% is not allowed for type%", P);
4168          end if;
4169
4170          Resolve (E1, P_Base_Type);
4171          Set_Etype (N, P_Base_Type);
4172
4173          --  Nothing to do for real type case
4174
4175          if Is_Real_Type (P_Type) then
4176             null;
4177
4178          --  If not modular type, test for overflow check required
4179
4180          else
4181             if not Is_Modular_Integer_Type (P_Type)
4182               and then not Range_Checks_Suppressed (P_Base_Type)
4183             then
4184                Enable_Range_Check (E1);
4185             end if;
4186          end if;
4187
4188       --------------
4189       -- Priority --
4190       --------------
4191
4192       --  Ada 2005 (AI-327): Dynamic ceiling priorities
4193
4194       when Attribute_Priority =>
4195          if Ada_Version < Ada_2005 then
4196             Error_Attr ("% attribute is allowed only in Ada 2005 mode", P);
4197          end if;
4198
4199          Check_E0;
4200
4201          --  The prefix must be a protected object (AARM D.5.2 (2/2))
4202
4203          Analyze (P);
4204
4205          if Is_Protected_Type (Etype (P))
4206            or else (Is_Access_Type (Etype (P))
4207                       and then Is_Protected_Type (Designated_Type (Etype (P))))
4208          then
4209             Resolve (P, Etype (P));
4210          else
4211             Error_Attr_P ("prefix of % attribute must be a protected object");
4212          end if;
4213
4214          Set_Etype (N, Standard_Integer);
4215
4216          --  Must be called from within a protected procedure or entry of the
4217          --  protected object.
4218
4219          declare
4220             S : Entity_Id;
4221
4222          begin
4223             S := Current_Scope;
4224             while S /= Etype (P)
4225                and then S /= Standard_Standard
4226             loop
4227                S := Scope (S);
4228             end loop;
4229
4230             if S = Standard_Standard then
4231                Error_Attr ("the attribute % is only allowed inside protected "
4232                            & "operations", P);
4233             end if;
4234          end;
4235
4236          Validate_Non_Static_Attribute_Function_Call;
4237
4238       -----------
4239       -- Range --
4240       -----------
4241
4242       when Attribute_Range =>
4243          Check_Array_Or_Scalar_Type;
4244          Bad_Attribute_For_Predicate;
4245
4246          if Ada_Version = Ada_83
4247            and then Is_Scalar_Type (P_Type)
4248            and then Comes_From_Source (N)
4249          then
4250             Error_Attr
4251               ("(Ada 83) % attribute not allowed for scalar type", P);
4252          end if;
4253
4254       ------------
4255       -- Result --
4256       ------------
4257
4258       when Attribute_Result => Result : declare
4259          CS : Entity_Id;
4260          --  The enclosing scope, excluding loops for quantified expressions
4261
4262          PS : Entity_Id;
4263          --  During analysis, CS is the postcondition subprogram and PS the
4264          --  source subprogram to which the postcondition applies. During
4265          --  pre-analysis, CS is the scope of the subprogram declaration.
4266
4267          Prag : Node_Id;
4268          --  During pre-analysis, Prag is the enclosing pragma node if any
4269
4270       begin
4271          --  Find enclosing scopes, excluding loops
4272
4273          CS := Current_Scope;
4274          while Ekind (CS) = E_Loop loop
4275             CS := Scope (CS);
4276          end loop;
4277
4278          PS := Scope (CS);
4279
4280          --  If the enclosing subprogram is always inlined, the enclosing
4281          --  postcondition will not be propagated to the expanded call.
4282
4283          if not In_Spec_Expression
4284            and then Has_Pragma_Inline_Always (PS)
4285            and then Warn_On_Redundant_Constructs
4286          then
4287             Error_Msg_N
4288               ("postconditions on inlined functions not enforced?", N);
4289          end if;
4290
4291          --  If we are in the scope of a function and in Spec_Expression mode,
4292          --  this is likely the prescan of the postcondition (or contract case,
4293          --  or test case) pragma, and we just set the proper type. If there is
4294          --  an error it will be caught when the real Analyze call is done.
4295
4296          if Ekind (CS) = E_Function
4297            and then In_Spec_Expression
4298          then
4299             --  Check OK prefix
4300
4301             if Chars (CS) /= Chars (P) then
4302                Error_Msg_Name_1 := Name_Result;
4303
4304                Error_Msg_NE
4305                  ("incorrect prefix for % attribute, expected &", P, CS);
4306                Error_Attr;
4307             end if;
4308
4309             --  Check in postcondition or Ensures clause of function
4310
4311             Prag := N;
4312             while not Nkind_In (Prag, N_Pragma,
4313                                       N_Function_Specification,
4314                                       N_Subprogram_Body)
4315             loop
4316                Prag := Parent (Prag);
4317             end loop;
4318
4319             if Nkind (Prag) /= N_Pragma then
4320                Error_Attr
4321                  ("% attribute can only appear in postcondition of function",
4322                   P);
4323
4324             elsif Get_Pragma_Id (Prag) = Pragma_Contract_Case
4325                     or else
4326                   Get_Pragma_Id (Prag) = Pragma_Test_Case
4327             then
4328                declare
4329                   Arg_Ens : constant Node_Id :=
4330                               Get_Ensures_From_CTC_Pragma (Prag);
4331                   Arg     : Node_Id;
4332
4333                begin
4334                   Arg := N;
4335                   while Arg /= Prag and Arg /= Arg_Ens loop
4336                      Arg := Parent (Arg);
4337                   end loop;
4338
4339                   if Arg /= Arg_Ens then
4340                      if Get_Pragma_Id (Prag) = Pragma_Contract_Case then
4341                         Error_Attr
4342                           ("% attribute misplaced inside contract case", P);
4343                      else
4344                         Error_Attr
4345                           ("% attribute misplaced inside test case", P);
4346                      end if;
4347                   end if;
4348                end;
4349
4350             elsif Get_Pragma_Id (Prag) /= Pragma_Postcondition then
4351                Error_Attr
4352                  ("% attribute can only appear in postcondition of function",
4353                   P);
4354             end if;
4355
4356             --  The attribute reference is a primary. If expressions follow,
4357             --  the attribute reference is really an indexable object, so
4358             --  rewrite and analyze as an indexed component.
4359
4360             if Present (E1) then
4361                Rewrite (N,
4362                  Make_Indexed_Component (Loc,
4363                    Prefix      =>
4364                      Make_Attribute_Reference (Loc,
4365                        Prefix         => Relocate_Node (Prefix (N)),
4366                        Attribute_Name => Name_Result),
4367                    Expressions => Expressions (N)));
4368                Analyze (N);
4369                return;
4370             end if;
4371
4372             Set_Etype (N, Etype (CS));
4373
4374             --  If several functions with that name are visible,
4375             --  the intended one is the current scope.
4376
4377             if Is_Overloaded (P) then
4378                Set_Entity (P, CS);
4379                Set_Is_Overloaded (P, False);
4380             end if;
4381
4382          --  Body case, where we must be inside a generated _Postcondition
4383          --  procedure, and the prefix must be on the scope stack, or else the
4384          --  attribute use is definitely misplaced. The postcondition itself
4385          --  may have generated transient scopes, and is not necessarily the
4386          --  current one.
4387
4388          else
4389             while Present (CS) and then CS /= Standard_Standard loop
4390                if Chars (CS) = Name_uPostconditions then
4391                   exit;
4392                else
4393                   CS := Scope (CS);
4394                end if;
4395             end loop;
4396
4397             PS := Scope (CS);
4398
4399             if Chars (CS) = Name_uPostconditions
4400               and then Ekind (PS) = E_Function
4401             then
4402                --  Check OK prefix
4403
4404                if Nkind_In (P, N_Identifier, N_Operator_Symbol)
4405                  and then Chars (P) = Chars (PS)
4406                then
4407                   null;
4408
4409                --  Within an instance, the prefix designates the local renaming
4410                --  of the original generic.
4411
4412                elsif Is_Entity_Name (P)
4413                  and then Ekind (Entity (P)) = E_Function
4414                  and then Present (Alias (Entity (P)))
4415                  and then Chars (Alias (Entity (P))) = Chars (PS)
4416                then
4417                   null;
4418
4419                else
4420                   Error_Msg_NE
4421                     ("incorrect prefix for % attribute, expected &", P, PS);
4422                   Error_Attr;
4423                end if;
4424
4425                Rewrite (N, Make_Identifier (Sloc (N), Name_uResult));
4426                Analyze_And_Resolve (N, Etype (PS));
4427
4428             else
4429                Error_Attr
4430                  ("% attribute can only appear in postcondition of function",
4431                   P);
4432             end if;
4433          end if;
4434       end Result;
4435
4436       ------------------
4437       -- Range_Length --
4438       ------------------
4439
4440       when Attribute_Range_Length =>
4441          Check_E0;
4442          Check_Discrete_Type;
4443          Set_Etype (N, Universal_Integer);
4444
4445       ----------
4446       -- Read --
4447       ----------
4448
4449       when Attribute_Read =>
4450          Check_E2;
4451          Check_Stream_Attribute (TSS_Stream_Read);
4452          Set_Etype (N, Standard_Void_Type);
4453          Resolve (N, Standard_Void_Type);
4454          Note_Possible_Modification (E2, Sure => True);
4455
4456       ---------
4457       -- Ref --
4458       ---------
4459
4460       when Attribute_Ref =>
4461          Check_E1;
4462          Analyze (P);
4463
4464          if Nkind (P) /= N_Expanded_Name
4465            or else not Is_RTE (P_Type, RE_Address)
4466          then
4467             Error_Attr_P ("prefix of % attribute must be System.Address");
4468          end if;
4469
4470          Analyze_And_Resolve (E1, Any_Integer);
4471          Set_Etype (N, RTE (RE_Address));
4472
4473       ---------------
4474       -- Remainder --
4475       ---------------
4476
4477       when Attribute_Remainder =>
4478          Check_Floating_Point_Type_2;
4479          Set_Etype (N, P_Base_Type);
4480          Resolve (E1, P_Base_Type);
4481          Resolve (E2, P_Base_Type);
4482
4483       -----------
4484       -- Round --
4485       -----------
4486
4487       when Attribute_Round =>
4488          Check_E1;
4489          Check_Decimal_Fixed_Point_Type;
4490          Set_Etype (N, P_Base_Type);
4491
4492          --  Because the context is universal_real (3.5.10(12)) it is a
4493          --  legal context for a universal fixed expression. This is the
4494          --  only attribute whose functional description involves U_R.
4495
4496          if Etype (E1) = Universal_Fixed then
4497             declare
4498                Conv : constant Node_Id := Make_Type_Conversion (Loc,
4499                   Subtype_Mark => New_Occurrence_Of (Universal_Real, Loc),
4500                   Expression   => Relocate_Node (E1));
4501
4502             begin
4503                Rewrite (E1, Conv);
4504                Analyze (E1);
4505             end;
4506          end if;
4507
4508          Resolve (E1, Any_Real);
4509
4510       --------------
4511       -- Rounding --
4512       --------------
4513
4514       when Attribute_Rounding =>
4515          Check_Floating_Point_Type_1;
4516          Set_Etype (N, P_Base_Type);
4517          Resolve (E1, P_Base_Type);
4518
4519       ---------------
4520       -- Safe_Emax --
4521       ---------------
4522
4523       when Attribute_Safe_Emax =>
4524          Check_Floating_Point_Type_0;
4525          Set_Etype (N, Universal_Integer);
4526
4527       ----------------
4528       -- Safe_First --
4529       ----------------
4530
4531       when Attribute_Safe_First =>
4532          Check_Floating_Point_Type_0;
4533          Set_Etype (N, Universal_Real);
4534
4535       ----------------
4536       -- Safe_Large --
4537       ----------------
4538
4539       when Attribute_Safe_Large =>
4540          Check_E0;
4541          Check_Real_Type;
4542          Set_Etype (N, Universal_Real);
4543
4544       ---------------
4545       -- Safe_Last --
4546       ---------------
4547
4548       when Attribute_Safe_Last =>
4549          Check_Floating_Point_Type_0;
4550          Set_Etype (N, Universal_Real);
4551
4552       ----------------
4553       -- Safe_Small --
4554       ----------------
4555
4556       when Attribute_Safe_Small =>
4557          Check_E0;
4558          Check_Real_Type;
4559          Set_Etype (N, Universal_Real);
4560
4561       ------------------
4562       -- Same_Storage --
4563       ------------------
4564
4565       when Attribute_Same_Storage =>
4566          Check_Ada_2012_Attribute;
4567          Check_E1;
4568
4569          --  The arguments must be objects of any type
4570
4571          Analyze_And_Resolve (P);
4572          Analyze_And_Resolve (E1);
4573          Check_Object_Reference (P);
4574          Check_Object_Reference (E1);
4575          Set_Etype (N, Standard_Boolean);
4576
4577       --------------------------
4578       -- Scalar_Storage_Order --
4579       --------------------------
4580
4581       when Attribute_Scalar_Storage_Order => Scalar_Storage_Order :
4582       begin
4583          Check_E0;
4584          Check_Type;
4585
4586          if not Is_Record_Type (P_Type) or else Is_Array_Type (P_Type) then
4587             Error_Attr_P
4588               ("prefix of % attribute must be record or array type");
4589          end if;
4590
4591          if Bytes_Big_Endian xor Reverse_Storage_Order (P_Type) then
4592             Rewrite (N,
4593               New_Occurrence_Of (RTE (RE_High_Order_First), Loc));
4594          else
4595             Rewrite (N,
4596               New_Occurrence_Of (RTE (RE_Low_Order_First), Loc));
4597          end if;
4598
4599          Set_Etype (N, RTE (RE_Bit_Order));
4600          Resolve (N);
4601
4602          --  Reset incorrect indication of staticness
4603
4604          Set_Is_Static_Expression (N, False);
4605       end Scalar_Storage_Order;
4606
4607       -----------
4608       -- Scale --
4609       -----------
4610
4611       when Attribute_Scale =>
4612          Check_E0;
4613          Check_Decimal_Fixed_Point_Type;
4614          Set_Etype (N, Universal_Integer);
4615
4616       -------------
4617       -- Scaling --
4618       -------------
4619
4620       when Attribute_Scaling =>
4621          Check_Floating_Point_Type_2;
4622          Set_Etype (N, P_Base_Type);
4623          Resolve (E1, P_Base_Type);
4624
4625       ------------------
4626       -- Signed_Zeros --
4627       ------------------
4628
4629       when Attribute_Signed_Zeros =>
4630          Check_Floating_Point_Type_0;
4631          Set_Etype (N, Standard_Boolean);
4632
4633       ----------
4634       -- Size --
4635       ----------
4636
4637       when Attribute_Size | Attribute_VADS_Size => Size :
4638       begin
4639          Check_E0;
4640
4641          --  If prefix is parameterless function call, rewrite and resolve
4642          --  as such.
4643
4644          if Is_Entity_Name (P)
4645            and then Ekind (Entity (P)) = E_Function
4646          then
4647             Resolve (P);
4648
4649          --  Similar processing for a protected function call
4650
4651          elsif Nkind (P) = N_Selected_Component
4652            and then Ekind (Entity (Selector_Name (P))) = E_Function
4653          then
4654             Resolve (P);
4655          end if;
4656
4657          if Is_Object_Reference (P) then
4658             Check_Object_Reference (P);
4659
4660          elsif Is_Entity_Name (P)
4661            and then (Is_Type (Entity (P))
4662                        or else Ekind (Entity (P)) = E_Enumeration_Literal)
4663          then
4664             null;
4665
4666          elsif Nkind (P) = N_Type_Conversion
4667            and then not Comes_From_Source (P)
4668          then
4669             null;
4670
4671          else
4672             Error_Attr_P ("invalid prefix for % attribute");
4673          end if;
4674
4675          Check_Not_Incomplete_Type;
4676          Check_Not_CPP_Type;
4677          Set_Etype (N, Universal_Integer);
4678       end Size;
4679
4680       -----------
4681       -- Small --
4682       -----------
4683
4684       when Attribute_Small =>
4685          Check_E0;
4686          Check_Real_Type;
4687          Set_Etype (N, Universal_Real);
4688
4689       ------------------
4690       -- Storage_Pool --
4691       ------------------
4692
4693       when Attribute_Storage_Pool        |
4694            Attribute_Simple_Storage_Pool => Storage_Pool :
4695       begin
4696          Check_E0;
4697
4698          if Is_Access_Type (P_Type) then
4699             if Ekind (P_Type) = E_Access_Subprogram_Type then
4700                Error_Attr_P
4701                  ("cannot use % attribute for access-to-subprogram type");
4702             end if;
4703
4704             --  Set appropriate entity
4705
4706             if Present (Associated_Storage_Pool (Root_Type (P_Type))) then
4707                Set_Entity (N, Associated_Storage_Pool (Root_Type (P_Type)));
4708             else
4709                Set_Entity (N, RTE (RE_Global_Pool_Object));
4710             end if;
4711
4712             if Attr_Id = Attribute_Storage_Pool then
4713                if Present (Get_Rep_Pragma (Etype (Entity (N)),
4714                                            Name_Simple_Storage_Pool_Type))
4715                then
4716                   Error_Msg_Name_1 := Aname;
4717                   Error_Msg_N ("cannot use % attribute for type with simple " &
4718                                "storage pool?", N);
4719                   Error_Msg_N
4720                      ("\Program_Error will be raised at run time?", N);
4721
4722                   Rewrite
4723                     (N, Make_Raise_Program_Error
4724                           (Sloc (N), Reason => PE_Explicit_Raise));
4725                end if;
4726
4727                Set_Etype (N, Class_Wide_Type (RTE (RE_Root_Storage_Pool)));
4728
4729             --  In the Simple_Storage_Pool case, verify that the pool entity is
4730             --  actually of a simple storage pool type, and set the attribute's
4731             --  type to the pool object's type.
4732
4733             else
4734                if not Present (Get_Rep_Pragma (Etype (Entity (N)),
4735                                                Name_Simple_Storage_Pool_Type))
4736                then
4737                   Error_Attr_P
4738                     ("cannot use % attribute for type without simple " &
4739                      "storage pool");
4740                end if;
4741
4742                Set_Etype (N, Etype (Entity (N)));
4743             end if;
4744
4745             --  Validate_Remote_Access_To_Class_Wide_Type for attribute
4746             --  Storage_Pool since this attribute is not defined for such
4747             --  types (RM E.2.3(22)).
4748
4749             Validate_Remote_Access_To_Class_Wide_Type (N);
4750
4751          else
4752             Error_Attr_P ("prefix of % attribute must be access type");
4753          end if;
4754       end Storage_Pool;
4755
4756       ------------------
4757       -- Storage_Size --
4758       ------------------
4759
4760       when Attribute_Storage_Size => Storage_Size :
4761       begin
4762          Check_E0;
4763
4764          if Is_Task_Type (P_Type) then
4765             Set_Etype (N, Universal_Integer);
4766
4767             --  Use with tasks is an obsolescent feature
4768
4769             Check_Restriction (No_Obsolescent_Features, P);
4770
4771          elsif Is_Access_Type (P_Type) then
4772             if Ekind (P_Type) = E_Access_Subprogram_Type then
4773                Error_Attr_P
4774                  ("cannot use % attribute for access-to-subprogram type");
4775             end if;
4776
4777             if Is_Entity_Name (P)
4778               and then Is_Type (Entity (P))
4779             then
4780                Check_Type;
4781                Set_Etype (N, Universal_Integer);
4782
4783                --   Validate_Remote_Access_To_Class_Wide_Type for attribute
4784                --   Storage_Size since this attribute is not defined for
4785                --   such types (RM E.2.3(22)).
4786
4787                Validate_Remote_Access_To_Class_Wide_Type (N);
4788
4789             --  The prefix is allowed to be an implicit dereference of an
4790             --  access value designating a task.
4791
4792             else
4793                Check_Task_Prefix;
4794                Set_Etype (N, Universal_Integer);
4795             end if;
4796
4797          else
4798             Error_Attr_P ("prefix of % attribute must be access or task type");
4799          end if;
4800       end Storage_Size;
4801
4802       ------------------
4803       -- Storage_Unit --
4804       ------------------
4805
4806       when Attribute_Storage_Unit =>
4807          Standard_Attribute (Ttypes.System_Storage_Unit);
4808
4809       -----------------
4810       -- Stream_Size --
4811       -----------------
4812
4813       when Attribute_Stream_Size =>
4814          Check_E0;
4815          Check_Type;
4816
4817          if Is_Entity_Name (P)
4818            and then Is_Elementary_Type (Entity (P))
4819          then
4820             Set_Etype (N, Universal_Integer);
4821          else
4822             Error_Attr_P ("invalid prefix for % attribute");
4823          end if;
4824
4825       ---------------
4826       -- Stub_Type --
4827       ---------------
4828
4829       when Attribute_Stub_Type =>
4830          Check_Type;
4831          Check_E0;
4832
4833          if Is_Remote_Access_To_Class_Wide_Type (Base_Type (P_Type)) then
4834
4835             --  For a real RACW [sub]type, use corresponding stub type
4836
4837             if not Is_Generic_Type (P_Type) then
4838                Rewrite (N,
4839                  New_Occurrence_Of
4840                    (Corresponding_Stub_Type (Base_Type (P_Type)), Loc));
4841
4842             --  For a generic type (that has been marked as an RACW using the
4843             --  Remote_Access_Type aspect or pragma), use a generic RACW stub
4844             --  type. Note that if the actual is not a remote access type, the
4845             --  instantiation will fail.
4846
4847             else
4848                --  Note: we go to the underlying type here because the view
4849                --  returned by RTE (RE_RACW_Stub_Type) might be incomplete.
4850
4851                Rewrite (N,
4852                  New_Occurrence_Of
4853                    (Underlying_Type (RTE (RE_RACW_Stub_Type)), Loc));
4854             end if;
4855
4856          else
4857             Error_Attr_P
4858               ("prefix of% attribute must be remote access to classwide");
4859          end if;
4860
4861       ----------
4862       -- Succ --
4863       ----------
4864
4865       when Attribute_Succ =>
4866          Check_Scalar_Type;
4867          Check_E1;
4868
4869          if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then
4870             Error_Msg_Name_1 := Aname;
4871             Error_Msg_Name_2 := Chars (P_Type);
4872             Check_SPARK_Restriction
4873               ("attribute% is not allowed for type%", P);
4874          end if;
4875
4876          Resolve (E1, P_Base_Type);
4877          Set_Etype (N, P_Base_Type);
4878
4879          --  Nothing to do for real type case
4880
4881          if Is_Real_Type (P_Type) then
4882             null;
4883
4884          --  If not modular type, test for overflow check required
4885
4886          else
4887             if not Is_Modular_Integer_Type (P_Type)
4888               and then not Range_Checks_Suppressed (P_Base_Type)
4889             then
4890                Enable_Range_Check (E1);
4891             end if;
4892          end if;
4893
4894       --------------------------------
4895       -- System_Allocator_Alignment --
4896       --------------------------------
4897
4898       when Attribute_System_Allocator_Alignment =>
4899          Standard_Attribute (Ttypes.System_Allocator_Alignment);
4900
4901       ---------
4902       -- Tag --
4903       ---------
4904
4905       when Attribute_Tag => Tag :
4906       begin
4907          Check_E0;
4908          Check_Dereference;
4909
4910          if not Is_Tagged_Type (P_Type) then
4911             Error_Attr_P ("prefix of % attribute must be tagged");
4912
4913          --  Next test does not apply to generated code
4914          --  why not, and what does the illegal reference mean???
4915
4916          elsif Is_Object_Reference (P)
4917            and then not Is_Class_Wide_Type (P_Type)
4918            and then Comes_From_Source (N)
4919          then
4920             Error_Attr_P
4921               ("% attribute can only be applied to objects " &
4922                "of class - wide type");
4923          end if;
4924
4925          --  The prefix cannot be an incomplete type. However, references
4926          --  to 'Tag can be generated when expanding interface conversions,
4927          --  and this is legal.
4928
4929          if Comes_From_Source (N) then
4930             Check_Not_Incomplete_Type;
4931          end if;
4932
4933          --  Set appropriate type
4934
4935          Set_Etype (N, RTE (RE_Tag));
4936       end Tag;
4937
4938       -----------------
4939       -- Target_Name --
4940       -----------------
4941
4942       when Attribute_Target_Name => Target_Name : declare
4943          TN : constant String := Sdefault.Target_Name.all;
4944          TL : Natural;
4945
4946       begin
4947          Check_Standard_Prefix;
4948
4949          TL := TN'Last;
4950
4951          if TN (TL) = '/' or else TN (TL) = '\' then
4952             TL := TL - 1;
4953          end if;
4954
4955          Rewrite (N,
4956            Make_String_Literal (Loc,
4957              Strval => TN (TN'First .. TL)));
4958          Analyze_And_Resolve (N, Standard_String);
4959       end Target_Name;
4960
4961       ----------------
4962       -- Terminated --
4963       ----------------
4964
4965       when Attribute_Terminated =>
4966          Check_E0;
4967          Set_Etype (N, Standard_Boolean);
4968          Check_Task_Prefix;
4969
4970       ----------------
4971       -- To_Address --
4972       ----------------
4973
4974       when Attribute_To_Address =>
4975          Check_E1;
4976          Analyze (P);
4977
4978          if Nkind (P) /= N_Identifier
4979            or else Chars (P) /= Name_System
4980          then
4981             Error_Attr_P ("prefix of % attribute must be System");
4982          end if;
4983
4984          Generate_Reference (RTE (RE_Address), P);
4985          Analyze_And_Resolve (E1, Any_Integer);
4986          Set_Etype (N, RTE (RE_Address));
4987
4988       ------------
4989       -- To_Any --
4990       ------------
4991
4992       when Attribute_To_Any =>
4993          Check_E1;
4994          Check_PolyORB_Attribute;
4995          Set_Etype (N, RTE (RE_Any));
4996
4997       ----------------
4998       -- Truncation --
4999       ----------------
5000
5001       when Attribute_Truncation =>
5002          Check_Floating_Point_Type_1;
5003          Resolve (E1, P_Base_Type);
5004          Set_Etype (N, P_Base_Type);
5005
5006       ----------------
5007       -- Type_Class --
5008       ----------------
5009
5010       when Attribute_Type_Class =>
5011          Check_E0;
5012          Check_Type;
5013          Check_Not_Incomplete_Type;
5014          Set_Etype (N, RTE (RE_Type_Class));
5015
5016       --------------
5017       -- TypeCode --
5018       --------------
5019
5020       when Attribute_TypeCode =>
5021          Check_E0;
5022          Check_PolyORB_Attribute;
5023          Set_Etype (N, RTE (RE_TypeCode));
5024
5025       --------------
5026       -- Type_Key --
5027       --------------
5028
5029       when Attribute_Type_Key =>
5030          Check_E0;
5031          Check_Type;
5032
5033          --  This processing belongs in Eval_Attribute ???
5034
5035          declare
5036             function Type_Key return String_Id;
5037             --  A very preliminary implementation. For now, a signature
5038             --  consists of only the type name. This is clearly incomplete
5039             --  (e.g., adding a new field to a record type should change the
5040             --  type's Type_Key attribute).
5041
5042             --------------
5043             -- Type_Key --
5044             --------------
5045
5046             function Type_Key return String_Id is
5047                Full_Name : constant String_Id :=
5048                              Fully_Qualified_Name_String (Entity (P));
5049
5050             begin
5051                --  Copy all characters in Full_Name but the trailing NUL
5052
5053                Start_String;
5054                for J in 1 .. String_Length (Full_Name) - 1 loop
5055                   Store_String_Char (Get_String_Char (Full_Name, Int (J)));
5056                end loop;
5057
5058                Store_String_Chars ("'Type_Key");
5059                return End_String;
5060             end Type_Key;
5061
5062          begin
5063             Rewrite (N, Make_String_Literal (Loc, Type_Key));
5064          end;
5065
5066          Analyze_And_Resolve (N, Standard_String);
5067
5068       -----------------
5069       -- UET_Address --
5070       -----------------
5071
5072       when Attribute_UET_Address =>
5073          Check_E0;
5074          Check_Unit_Name (P);
5075          Set_Etype (N, RTE (RE_Address));
5076
5077       -----------------------
5078       -- Unbiased_Rounding --
5079       -----------------------
5080
5081       when Attribute_Unbiased_Rounding =>
5082          Check_Floating_Point_Type_1;
5083          Set_Etype (N, P_Base_Type);
5084          Resolve (E1, P_Base_Type);
5085
5086       ----------------------
5087       -- Unchecked_Access --
5088       ----------------------
5089
5090       when Attribute_Unchecked_Access =>
5091          if Comes_From_Source (N) then
5092             Check_Restriction (No_Unchecked_Access, N);
5093          end if;
5094
5095          Analyze_Access_Attribute;
5096
5097       -------------------------
5098       -- Unconstrained_Array --
5099       -------------------------
5100
5101       when Attribute_Unconstrained_Array =>
5102          Check_E0;
5103          Check_Type;
5104          Check_Not_Incomplete_Type;
5105          Set_Etype (N, Standard_Boolean);
5106
5107       ------------------------------
5108       -- Universal_Literal_String --
5109       ------------------------------
5110
5111       --  This is a GNAT specific attribute whose prefix must be a named
5112       --  number where the expression is either a single numeric literal,
5113       --  or a numeric literal immediately preceded by a minus sign. The
5114       --  result is equivalent to a string literal containing the text of
5115       --  the literal as it appeared in the source program with a possible
5116       --  leading minus sign.
5117
5118       when Attribute_Universal_Literal_String => Universal_Literal_String :
5119       begin
5120          Check_E0;
5121
5122          if not Is_Entity_Name (P)
5123            or else Ekind (Entity (P)) not in Named_Kind
5124          then
5125             Error_Attr_P ("prefix for % attribute must be named number");
5126
5127          else
5128             declare
5129                Expr     : Node_Id;
5130                Negative : Boolean;
5131                S        : Source_Ptr;
5132                Src      : Source_Buffer_Ptr;
5133
5134             begin
5135                Expr := Original_Node (Expression (Parent (Entity (P))));
5136
5137                if Nkind (Expr) = N_Op_Minus then
5138                   Negative := True;
5139                   Expr := Original_Node (Right_Opnd (Expr));
5140                else
5141                   Negative := False;
5142                end if;
5143
5144                if not Nkind_In (Expr, N_Integer_Literal, N_Real_Literal) then
5145                   Error_Attr
5146                     ("named number for % attribute must be simple literal", N);
5147                end if;
5148
5149                --  Build string literal corresponding to source literal text
5150
5151                Start_String;
5152
5153                if Negative then
5154                   Store_String_Char (Get_Char_Code ('-'));
5155                end if;
5156
5157                S := Sloc (Expr);
5158                Src := Source_Text (Get_Source_File_Index (S));
5159
5160                while Src (S) /= ';' and then Src (S) /= ' ' loop
5161                   Store_String_Char (Get_Char_Code (Src (S)));
5162                   S := S + 1;
5163                end loop;
5164
5165                --  Now we rewrite the attribute with the string literal
5166
5167                Rewrite (N,
5168                  Make_String_Literal (Loc, End_String));
5169                Analyze (N);
5170             end;
5171          end if;
5172       end Universal_Literal_String;
5173
5174       -------------------------
5175       -- Unrestricted_Access --
5176       -------------------------
5177
5178       --  This is a GNAT specific attribute which is like Access except that
5179       --  all scope checks and checks for aliased views are omitted.
5180
5181       when Attribute_Unrestricted_Access =>
5182
5183          --  If from source, deal with relevant restrictions
5184
5185          if Comes_From_Source (N) then
5186             Check_Restriction (No_Unchecked_Access, N);
5187
5188             if Nkind (P) in N_Has_Entity
5189               and then Present (Entity (P))
5190               and then Is_Object (Entity (P))
5191             then
5192                Check_Restriction (No_Implicit_Aliasing, N);
5193             end if;
5194          end if;
5195
5196          if Is_Entity_Name (P) then
5197             Set_Address_Taken (Entity (P));
5198          end if;
5199
5200          Analyze_Access_Attribute;
5201
5202       ---------
5203       -- Val --
5204       ---------
5205
5206       when Attribute_Val => Val : declare
5207       begin
5208          Check_E1;
5209          Check_Discrete_Type;
5210
5211          if Is_Boolean_Type (P_Type) then
5212             Error_Msg_Name_1 := Aname;
5213             Error_Msg_Name_2 := Chars (P_Type);
5214             Check_SPARK_Restriction
5215               ("attribute% is not allowed for type%", P);
5216          end if;
5217
5218          Resolve (E1, Any_Integer);
5219          Set_Etype (N, P_Base_Type);
5220
5221          --  Note, we need a range check in general, but we wait for the
5222          --  Resolve call to do this, since we want to let Eval_Attribute
5223          --  have a chance to find an static illegality first!
5224       end Val;
5225
5226       -----------
5227       -- Valid --
5228       -----------
5229
5230       when Attribute_Valid =>
5231          Check_E0;
5232
5233          --  Ignore check for object if we have a 'Valid reference generated
5234          --  by the expanded code, since in some cases valid checks can occur
5235          --  on items that are names, but are not objects (e.g. attributes).
5236
5237          if Comes_From_Source (N) then
5238             Check_Object_Reference (P);
5239          end if;
5240
5241          if not Is_Scalar_Type (P_Type) then
5242             Error_Attr_P ("object for % attribute must be of scalar type");
5243          end if;
5244
5245          Set_Etype (N, Standard_Boolean);
5246
5247       -------------------
5248       -- Valid_Scalars --
5249       -------------------
5250
5251       when Attribute_Valid_Scalars =>
5252          Check_E0;
5253          Check_Object_Reference (P);
5254
5255          if No_Scalar_Parts (P_Type) then
5256             Error_Attr_P ("?attribute % always True, no scalars to check");
5257          end if;
5258
5259          Set_Etype (N, Standard_Boolean);
5260
5261       -----------
5262       -- Value --
5263       -----------
5264
5265       when Attribute_Value => Value :
5266       begin
5267          Check_SPARK_Restriction_On_Attribute;
5268          Check_E1;
5269          Check_Scalar_Type;
5270
5271          --  Case of enumeration type
5272
5273          --  When an enumeration type appears in an attribute reference, all
5274          --  literals of the type are marked as referenced. This must only be
5275          --  done if the attribute reference appears in the current source.
5276          --  Otherwise the information on references may differ between a
5277          --  normal compilation and one that performs inlining.
5278
5279          if Is_Enumeration_Type (P_Type)
5280            and then In_Extended_Main_Code_Unit (N)
5281          then
5282             Check_Restriction (No_Enumeration_Maps, N);
5283
5284             --  Mark all enumeration literals as referenced, since the use of
5285             --  the Value attribute can implicitly reference any of the
5286             --  literals of the enumeration base type.
5287
5288             declare
5289                Ent : Entity_Id := First_Literal (P_Base_Type);
5290             begin
5291                while Present (Ent) loop
5292                   Set_Referenced (Ent);
5293                   Next_Literal (Ent);
5294                end loop;
5295             end;
5296          end if;
5297
5298          --  Set Etype before resolving expression because expansion of
5299          --  expression may require enclosing type. Note that the type
5300          --  returned by 'Value is the base type of the prefix type.
5301
5302          Set_Etype (N, P_Base_Type);
5303          Validate_Non_Static_Attribute_Function_Call;
5304       end Value;
5305
5306       ----------------
5307       -- Value_Size --
5308       ----------------
5309
5310       when Attribute_Value_Size =>
5311          Check_E0;
5312          Check_Type;
5313          Check_Not_Incomplete_Type;
5314          Set_Etype (N, Universal_Integer);
5315
5316       -------------
5317       -- Version --
5318       -------------
5319
5320       when Attribute_Version =>
5321          Check_E0;
5322          Check_Program_Unit;
5323          Set_Etype (N, RTE (RE_Version_String));
5324
5325       ------------------
5326       -- Wchar_T_Size --
5327       ------------------
5328
5329       when Attribute_Wchar_T_Size =>
5330          Standard_Attribute (Interfaces_Wchar_T_Size);
5331
5332       ----------------
5333       -- Wide_Image --
5334       ----------------
5335
5336       when Attribute_Wide_Image => Wide_Image :
5337       begin
5338          Check_SPARK_Restriction_On_Attribute;
5339          Check_Scalar_Type;
5340          Set_Etype (N, Standard_Wide_String);
5341          Check_E1;
5342          Resolve (E1, P_Base_Type);
5343          Validate_Non_Static_Attribute_Function_Call;
5344       end Wide_Image;
5345
5346       ---------------------
5347       -- Wide_Wide_Image --
5348       ---------------------
5349
5350       when Attribute_Wide_Wide_Image => Wide_Wide_Image :
5351       begin
5352          Check_Scalar_Type;
5353          Set_Etype (N, Standard_Wide_Wide_String);
5354          Check_E1;
5355          Resolve (E1, P_Base_Type);
5356          Validate_Non_Static_Attribute_Function_Call;
5357       end Wide_Wide_Image;
5358
5359       ----------------
5360       -- Wide_Value --
5361       ----------------
5362
5363       when Attribute_Wide_Value => Wide_Value :
5364       begin
5365          Check_SPARK_Restriction_On_Attribute;
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_Value;
5375
5376       ---------------------
5377       -- Wide_Wide_Value --
5378       ---------------------
5379
5380       when Attribute_Wide_Wide_Value => Wide_Wide_Value :
5381       begin
5382          Check_E1;
5383          Check_Scalar_Type;
5384
5385          --  Set Etype before resolving expression because expansion
5386          --  of expression may require enclosing type.
5387
5388          Set_Etype (N, P_Type);
5389          Validate_Non_Static_Attribute_Function_Call;
5390       end Wide_Wide_Value;
5391
5392       ---------------------
5393       -- Wide_Wide_Width --
5394       ---------------------
5395
5396       when Attribute_Wide_Wide_Width =>
5397          Check_E0;
5398          Check_Scalar_Type;
5399          Set_Etype (N, Universal_Integer);
5400
5401       ----------------
5402       -- Wide_Width --
5403       ----------------
5404
5405       when Attribute_Wide_Width =>
5406          Check_SPARK_Restriction_On_Attribute;
5407          Check_E0;
5408          Check_Scalar_Type;
5409          Set_Etype (N, Universal_Integer);
5410
5411       -----------
5412       -- Width --
5413       -----------
5414
5415       when Attribute_Width =>
5416          Check_SPARK_Restriction_On_Attribute;
5417          Check_E0;
5418          Check_Scalar_Type;
5419          Set_Etype (N, Universal_Integer);
5420
5421       ---------------
5422       -- Word_Size --
5423       ---------------
5424
5425       when Attribute_Word_Size =>
5426          Standard_Attribute (System_Word_Size);
5427
5428       -----------
5429       -- Write --
5430       -----------
5431
5432       when Attribute_Write =>
5433          Check_E2;
5434          Check_Stream_Attribute (TSS_Stream_Write);
5435          Set_Etype (N, Standard_Void_Type);
5436          Resolve (N, Standard_Void_Type);
5437
5438       end case;
5439
5440    --  All errors raise Bad_Attribute, so that we get out before any further
5441    --  damage occurs when an error is detected (for example, if we check for
5442    --  one attribute expression, and the check succeeds, we want to be able
5443    --  to proceed securely assuming that an expression is in fact present.
5444
5445    --  Note: we set the attribute analyzed in this case to prevent any
5446    --  attempt at reanalysis which could generate spurious error msgs.
5447
5448    exception
5449       when Bad_Attribute =>
5450          Set_Analyzed (N);
5451          Set_Etype (N, Any_Type);
5452          return;
5453    end Analyze_Attribute;
5454
5455    --------------------
5456    -- Eval_Attribute --
5457    --------------------
5458
5459    procedure Eval_Attribute (N : Node_Id) is
5460       Loc   : constant Source_Ptr   := Sloc (N);
5461       Aname : constant Name_Id      := Attribute_Name (N);
5462       Id    : constant Attribute_Id := Get_Attribute_Id (Aname);
5463       P     : constant Node_Id      := Prefix (N);
5464
5465       C_Type : constant Entity_Id := Etype (N);
5466       --  The type imposed by the context
5467
5468       E1 : Node_Id;
5469       --  First expression, or Empty if none
5470
5471       E2 : Node_Id;
5472       --  Second expression, or Empty if none
5473
5474       P_Entity : Entity_Id;
5475       --  Entity denoted by prefix
5476
5477       P_Type : Entity_Id;
5478       --  The type of the prefix
5479
5480       P_Base_Type : Entity_Id;
5481       --  The base type of the prefix type
5482
5483       P_Root_Type : Entity_Id;
5484       --  The root type of the prefix type
5485
5486       Static : Boolean;
5487       --  True if the result is Static. This is set by the general processing
5488       --  to true if the prefix is static, and all expressions are static. It
5489       --  can be reset as processing continues for particular attributes
5490
5491       Lo_Bound, Hi_Bound : Node_Id;
5492       --  Expressions for low and high bounds of type or array index referenced
5493       --  by First, Last, or Length attribute for array, set by Set_Bounds.
5494
5495       CE_Node : Node_Id;
5496       --  Constraint error node used if we have an attribute reference has
5497       --  an argument that raises a constraint error. In this case we replace
5498       --  the attribute with a raise constraint_error node. This is important
5499       --  processing, since otherwise gigi might see an attribute which it is
5500       --  unprepared to deal with.
5501
5502       procedure Check_Concurrent_Discriminant (Bound : Node_Id);
5503       --  If Bound is a reference to a discriminant of a task or protected type
5504       --  occurring within the object's body, rewrite attribute reference into
5505       --  a reference to the corresponding discriminal. Use for the expansion
5506       --  of checks against bounds of entry family index subtypes.
5507
5508       procedure Check_Expressions;
5509       --  In case where the attribute is not foldable, the expressions, if
5510       --  any, of the attribute, are in a non-static context. This procedure
5511       --  performs the required additional checks.
5512
5513       function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean;
5514       --  Determines if the given type has compile time known bounds. Note
5515       --  that we enter the case statement even in cases where the prefix
5516       --  type does NOT have known bounds, so it is important to guard any
5517       --  attempt to evaluate both bounds with a call to this function.
5518
5519       procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint);
5520       --  This procedure is called when the attribute N has a non-static
5521       --  but compile time known value given by Val. It includes the
5522       --  necessary checks for out of range values.
5523
5524       function Fore_Value return Nat;
5525       --  Computes the Fore value for the current attribute prefix, which is
5526       --  known to be a static fixed-point type. Used by Fore and Width.
5527
5528       function Is_VAX_Float (Typ : Entity_Id) return Boolean;
5529       --  Determine whether Typ denotes a VAX floating point type
5530
5531       function Mantissa return Uint;
5532       --  Returns the Mantissa value for the prefix type
5533
5534       procedure Set_Bounds;
5535       --  Used for First, Last and Length attributes applied to an array or
5536       --  array subtype. Sets the variables Lo_Bound and Hi_Bound to the low
5537       --  and high bound expressions for the index referenced by the attribute
5538       --  designator (i.e. the first index if no expression is present, and the
5539       --  N'th index if the value N is present as an expression). Also used for
5540       --  First and Last of scalar types and for First_Valid and Last_Valid.
5541       --  Static is reset to False if the type or index type is not statically
5542       --  constrained.
5543
5544       function Statically_Denotes_Entity (N : Node_Id) return Boolean;
5545       --  Verify that the prefix of a potentially static array attribute
5546       --  satisfies the conditions of 4.9 (14).
5547
5548       -----------------------------------
5549       -- Check_Concurrent_Discriminant --
5550       -----------------------------------
5551
5552       procedure Check_Concurrent_Discriminant (Bound : Node_Id) is
5553          Tsk : Entity_Id;
5554          --  The concurrent (task or protected) type
5555
5556       begin
5557          if Nkind (Bound) = N_Identifier
5558            and then Ekind (Entity (Bound)) = E_Discriminant
5559            and then Is_Concurrent_Record_Type (Scope (Entity (Bound)))
5560          then
5561             Tsk := Corresponding_Concurrent_Type (Scope (Entity (Bound)));
5562
5563             if In_Open_Scopes (Tsk) and then Has_Completion (Tsk) then
5564
5565                --  Find discriminant of original concurrent type, and use
5566                --  its current discriminal, which is the renaming within
5567                --  the task/protected body.
5568
5569                Rewrite (N,
5570                  New_Occurrence_Of
5571                    (Find_Body_Discriminal (Entity (Bound)), Loc));
5572             end if;
5573          end if;
5574       end Check_Concurrent_Discriminant;
5575
5576       -----------------------
5577       -- Check_Expressions --
5578       -----------------------
5579
5580       procedure Check_Expressions is
5581          E : Node_Id;
5582       begin
5583          E := E1;
5584          while Present (E) loop
5585             Check_Non_Static_Context (E);
5586             Next (E);
5587          end loop;
5588       end Check_Expressions;
5589
5590       ----------------------------------
5591       -- Compile_Time_Known_Attribute --
5592       ----------------------------------
5593
5594       procedure Compile_Time_Known_Attribute (N : Node_Id; Val : Uint) is
5595          T : constant Entity_Id := Etype (N);
5596
5597       begin
5598          Fold_Uint (N, Val, False);
5599
5600          --  Check that result is in bounds of the type if it is static
5601
5602          if Is_In_Range (N, T, Assume_Valid => False) then
5603             null;
5604
5605          elsif Is_Out_Of_Range (N, T) then
5606             Apply_Compile_Time_Constraint_Error
5607               (N, "value not in range of}?", CE_Range_Check_Failed);
5608
5609          elsif not Range_Checks_Suppressed (T) then
5610             Enable_Range_Check (N);
5611
5612          else
5613             Set_Do_Range_Check (N, False);
5614          end if;
5615       end Compile_Time_Known_Attribute;
5616
5617       -------------------------------
5618       -- Compile_Time_Known_Bounds --
5619       -------------------------------
5620
5621       function Compile_Time_Known_Bounds (Typ : Entity_Id) return Boolean is
5622       begin
5623          return
5624            Compile_Time_Known_Value (Type_Low_Bound (Typ))
5625              and then
5626            Compile_Time_Known_Value (Type_High_Bound (Typ));
5627       end Compile_Time_Known_Bounds;
5628
5629       ----------------
5630       -- Fore_Value --
5631       ----------------
5632
5633       --  Note that the Fore calculation is based on the actual values
5634       --  of the bounds, and does not take into account possible rounding.
5635
5636       function Fore_Value return Nat is
5637          Lo      : constant Uint  := Expr_Value (Type_Low_Bound (P_Type));
5638          Hi      : constant Uint  := Expr_Value (Type_High_Bound (P_Type));
5639          Small   : constant Ureal := Small_Value (P_Type);
5640          Lo_Real : constant Ureal := Lo * Small;
5641          Hi_Real : constant Ureal := Hi * Small;
5642          T       : Ureal;
5643          R       : Nat;
5644
5645       begin
5646          --  Bounds are given in terms of small units, so first compute
5647          --  proper values as reals.
5648
5649          T := UR_Max (abs Lo_Real, abs Hi_Real);
5650          R := 2;
5651
5652          --  Loop to compute proper value if more than one digit required
5653
5654          while T >= Ureal_10 loop
5655             R := R + 1;
5656             T := T / Ureal_10;
5657          end loop;
5658
5659          return R;
5660       end Fore_Value;
5661
5662       ------------------
5663       -- Is_VAX_Float --
5664       ------------------
5665
5666       function Is_VAX_Float (Typ : Entity_Id) return Boolean is
5667       begin
5668          return
5669            Is_Floating_Point_Type (Typ)
5670              and then
5671                (Float_Format = 'V'
5672                   or else Float_Rep (Typ) = VAX_Native);
5673       end Is_VAX_Float;
5674
5675       --------------
5676       -- Mantissa --
5677       --------------
5678
5679       --  Table of mantissa values accessed by function  Computed using
5680       --  the relation:
5681
5682       --    T'Mantissa = integer next above (D * log(10)/log(2)) + 1)
5683
5684       --  where D is T'Digits (RM83 3.5.7)
5685
5686       Mantissa_Value : constant array (Nat range 1 .. 40) of Nat := (
5687           1 =>   5,
5688           2 =>   8,
5689           3 =>  11,
5690           4 =>  15,
5691           5 =>  18,
5692           6 =>  21,
5693           7 =>  25,
5694           8 =>  28,
5695           9 =>  31,
5696          10 =>  35,
5697          11 =>  38,
5698          12 =>  41,
5699          13 =>  45,
5700          14 =>  48,
5701          15 =>  51,
5702          16 =>  55,
5703          17 =>  58,
5704          18 =>  61,
5705          19 =>  65,
5706          20 =>  68,
5707          21 =>  71,
5708          22 =>  75,
5709          23 =>  78,
5710          24 =>  81,
5711          25 =>  85,
5712          26 =>  88,
5713          27 =>  91,
5714          28 =>  95,
5715          29 =>  98,
5716          30 => 101,
5717          31 => 104,
5718          32 => 108,
5719          33 => 111,
5720          34 => 114,
5721          35 => 118,
5722          36 => 121,
5723          37 => 124,
5724          38 => 128,
5725          39 => 131,
5726          40 => 134);
5727
5728       function Mantissa return Uint is
5729       begin
5730          return
5731            UI_From_Int (Mantissa_Value (UI_To_Int (Digits_Value (P_Type))));
5732       end Mantissa;
5733
5734       ----------------
5735       -- Set_Bounds --
5736       ----------------
5737
5738       procedure Set_Bounds is
5739          Ndim : Nat;
5740          Indx : Node_Id;
5741          Ityp : Entity_Id;
5742
5743       begin
5744          --  For a string literal subtype, we have to construct the bounds.
5745          --  Valid Ada code never applies attributes to string literals, but
5746          --  it is convenient to allow the expander to generate attribute
5747          --  references of this type (e.g. First and Last applied to a string
5748          --  literal).
5749
5750          --  Note that the whole point of the E_String_Literal_Subtype is to
5751          --  avoid this construction of bounds, but the cases in which we
5752          --  have to materialize them are rare enough that we don't worry!
5753
5754          --  The low bound is simply the low bound of the base type. The
5755          --  high bound is computed from the length of the string and this
5756          --  low bound.
5757
5758          if Ekind (P_Type) = E_String_Literal_Subtype then
5759             Ityp := Etype (First_Index (Base_Type (P_Type)));
5760             Lo_Bound := Type_Low_Bound (Ityp);
5761
5762             Hi_Bound :=
5763               Make_Integer_Literal (Sloc (P),
5764                 Intval =>
5765                   Expr_Value (Lo_Bound) + String_Literal_Length (P_Type) - 1);
5766
5767             Set_Parent (Hi_Bound, P);
5768             Analyze_And_Resolve (Hi_Bound, Etype (Lo_Bound));
5769             return;
5770
5771          --  For non-array case, just get bounds of scalar type
5772
5773          elsif Is_Scalar_Type (P_Type) then
5774             Ityp := P_Type;
5775
5776             --  For a fixed-point type, we must freeze to get the attributes
5777             --  of the fixed-point type set now so we can reference them.
5778
5779             if Is_Fixed_Point_Type (P_Type)
5780               and then not Is_Frozen (Base_Type (P_Type))
5781               and then Compile_Time_Known_Value (Type_Low_Bound (P_Type))
5782               and then Compile_Time_Known_Value (Type_High_Bound (P_Type))
5783             then
5784                Freeze_Fixed_Point_Type (Base_Type (P_Type));
5785             end if;
5786
5787          --  For array case, get type of proper index
5788
5789          else
5790             if No (E1) then
5791                Ndim := 1;
5792             else
5793                Ndim := UI_To_Int (Expr_Value (E1));
5794             end if;
5795
5796             Indx := First_Index (P_Type);
5797             for J in 1 .. Ndim - 1 loop
5798                Next_Index (Indx);
5799             end loop;
5800
5801             --  If no index type, get out (some other error occurred, and
5802             --  we don't have enough information to complete the job!)
5803
5804             if No (Indx) then
5805                Lo_Bound := Error;
5806                Hi_Bound := Error;
5807                return;
5808             end if;
5809
5810             Ityp := Etype (Indx);
5811          end if;
5812
5813          --  A discrete range in an index constraint is allowed to be a
5814          --  subtype indication. This is syntactically a pain, but should
5815          --  not propagate to the entity for the corresponding index subtype.
5816          --  After checking that the subtype indication is legal, the range
5817          --  of the subtype indication should be transfered to the entity.
5818          --  The attributes for the bounds should remain the simple retrievals
5819          --  that they are now.
5820
5821          Lo_Bound := Type_Low_Bound (Ityp);
5822          Hi_Bound := Type_High_Bound (Ityp);
5823
5824          if not Is_Static_Subtype (Ityp) then
5825             Static := False;
5826          end if;
5827       end Set_Bounds;
5828
5829       -------------------------------
5830       -- Statically_Denotes_Entity --
5831       -------------------------------
5832
5833       function Statically_Denotes_Entity (N : Node_Id) return Boolean is
5834          E : Entity_Id;
5835
5836       begin
5837          if not Is_Entity_Name (N) then
5838             return False;
5839          else
5840             E := Entity (N);
5841          end if;
5842
5843          return
5844            Nkind (Parent (E)) /= N_Object_Renaming_Declaration
5845              or else Statically_Denotes_Entity (Renamed_Object (E));
5846       end Statically_Denotes_Entity;
5847
5848    --  Start of processing for Eval_Attribute
5849
5850    begin
5851       --  Acquire first two expressions (at the moment, no attributes take more
5852       --  than two expressions in any case).
5853
5854       if Present (Expressions (N)) then
5855          E1 := First (Expressions (N));
5856          E2 := Next (E1);
5857       else
5858          E1 := Empty;
5859          E2 := Empty;
5860       end if;
5861
5862       --  Special processing for Enabled attribute. This attribute has a very
5863       --  special prefix, and the easiest way to avoid lots of special checks
5864       --  to protect this special prefix from causing trouble is to deal with
5865       --  this attribute immediately and be done with it.
5866
5867       if Id = Attribute_Enabled then
5868
5869          --  We skip evaluation if the expander is not active. This is not just
5870          --  an optimization. It is of key importance that we not rewrite the
5871          --  attribute in a generic template, since we want to pick up the
5872          --  setting of the check in the instance, and testing expander active
5873          --  is as easy way of doing this as any.
5874
5875          if Expander_Active then
5876             declare
5877                C : constant Check_Id := Get_Check_Id (Chars (P));
5878                R : Boolean;
5879
5880             begin
5881                if No (E1) then
5882                   if C in Predefined_Check_Id then
5883                      R := Scope_Suppress.Suppress (C);
5884                   else
5885                      R := Is_Check_Suppressed (Empty, C);
5886                   end if;
5887
5888                else
5889                   R := Is_Check_Suppressed (Entity (E1), C);
5890                end if;
5891
5892                Rewrite (N, New_Occurrence_Of (Boolean_Literals (not R), Loc));
5893             end;
5894          end if;
5895
5896          return;
5897       end if;
5898
5899       --  Special processing for cases where the prefix is an object. For
5900       --  this purpose, a string literal counts as an object (attributes
5901       --  of string literals can only appear in generated code).
5902
5903       if Is_Object_Reference (P) or else Nkind (P) = N_String_Literal then
5904
5905          --  For Component_Size, the prefix is an array object, and we apply
5906          --  the attribute to the type of the object. This is allowed for
5907          --  both unconstrained and constrained arrays, since the bounds
5908          --  have no influence on the value of this attribute.
5909
5910          if Id = Attribute_Component_Size then
5911             P_Entity := Etype (P);
5912
5913          --  For First and Last, the prefix is an array object, and we apply
5914          --  the attribute to the type of the array, but we need a constrained
5915          --  type for this, so we use the actual subtype if available.
5916
5917          elsif Id = Attribute_First
5918                  or else
5919                Id = Attribute_Last
5920                  or else
5921                Id = Attribute_Length
5922          then
5923             declare
5924                AS : constant Entity_Id := Get_Actual_Subtype_If_Available (P);
5925
5926             begin
5927                if Present (AS) and then Is_Constrained (AS) then
5928                   P_Entity := AS;
5929
5930                --  If we have an unconstrained type we cannot fold
5931
5932                else
5933                   Check_Expressions;
5934                   return;
5935                end if;
5936             end;
5937
5938          --  For Size, give size of object if available, otherwise we
5939          --  cannot fold Size.
5940
5941          elsif Id = Attribute_Size then
5942             if Is_Entity_Name (P)
5943               and then Known_Esize (Entity (P))
5944             then
5945                Compile_Time_Known_Attribute (N, Esize (Entity (P)));
5946                return;
5947
5948             else
5949                Check_Expressions;
5950                return;
5951             end if;
5952
5953          --  For Alignment, give size of object if available, otherwise we
5954          --  cannot fold Alignment.
5955
5956          elsif Id = Attribute_Alignment then
5957             if Is_Entity_Name (P)
5958               and then Known_Alignment (Entity (P))
5959             then
5960                Fold_Uint (N, Alignment (Entity (P)), False);
5961                return;
5962
5963             else
5964                Check_Expressions;
5965                return;
5966             end if;
5967
5968          --  For Lock_Free, we apply the attribute to the type of the object.
5969          --  This is allowed since we have already verified that the type is a
5970          --  protected type.
5971
5972          elsif Id = Attribute_Lock_Free then
5973             P_Entity := Etype (P);
5974
5975          --  No other attributes for objects are folded
5976
5977          else
5978             Check_Expressions;
5979             return;
5980          end if;
5981
5982       --  Cases where P is not an object. Cannot do anything if P is
5983       --  not the name of an entity.
5984
5985       elsif not Is_Entity_Name (P) then
5986          Check_Expressions;
5987          return;
5988
5989       --  Otherwise get prefix entity
5990
5991       else
5992          P_Entity := Entity (P);
5993       end if;
5994
5995       --  At this stage P_Entity is the entity to which the attribute
5996       --  is to be applied. This is usually simply the entity of the
5997       --  prefix, except in some cases of attributes for objects, where
5998       --  as described above, we apply the attribute to the object type.
5999
6000       --  First foldable possibility is a scalar or array type (RM 4.9(7))
6001       --  that is not generic (generic types are eliminated by RM 4.9(25)).
6002       --  Note we allow non-static non-generic types at this stage as further
6003       --  described below.
6004
6005       if Is_Type (P_Entity)
6006         and then (Is_Scalar_Type (P_Entity) or Is_Array_Type (P_Entity))
6007         and then (not Is_Generic_Type (P_Entity))
6008       then
6009          P_Type := P_Entity;
6010
6011       --  Second foldable possibility is an array object (RM 4.9(8))
6012
6013       elsif (Ekind (P_Entity) = E_Variable
6014                or else
6015              Ekind (P_Entity) = E_Constant)
6016         and then Is_Array_Type (Etype (P_Entity))
6017         and then (not Is_Generic_Type (Etype (P_Entity)))
6018       then
6019          P_Type := Etype (P_Entity);
6020
6021          --  If the entity is an array constant with an unconstrained nominal
6022          --  subtype then get the type from the initial value. If the value has
6023          --  been expanded into assignments, there is no expression and the
6024          --  attribute reference remains dynamic.
6025
6026          --  We could do better here and retrieve the type ???
6027
6028          if Ekind (P_Entity) = E_Constant
6029            and then not Is_Constrained (P_Type)
6030          then
6031             if No (Constant_Value (P_Entity)) then
6032                return;
6033             else
6034                P_Type := Etype (Constant_Value (P_Entity));
6035             end if;
6036          end if;
6037
6038       --  Definite must be folded if the prefix is not a generic type,
6039       --  that is to say if we are within an instantiation. Same processing
6040       --  applies to the GNAT attributes Atomic_Always_Lock_Free,
6041       --  Has_Discriminants, Lock_Free, Type_Class, Has_Tagged_Value, and
6042       --  Unconstrained_Array.
6043
6044       elsif (Id = Attribute_Atomic_Always_Lock_Free
6045                or else
6046              Id = Attribute_Definite
6047                or else
6048              Id = Attribute_Has_Access_Values
6049                or else
6050              Id = Attribute_Has_Discriminants
6051                or else
6052              Id = Attribute_Has_Tagged_Values
6053                or else
6054              Id = Attribute_Lock_Free
6055                or else
6056              Id = Attribute_Type_Class
6057                or else
6058              Id = Attribute_Unconstrained_Array
6059                or else
6060              Id = Attribute_Max_Alignment_For_Allocation)
6061         and then not Is_Generic_Type (P_Entity)
6062       then
6063          P_Type := P_Entity;
6064
6065       --  We can fold 'Size applied to a type if the size is known (as happens
6066       --  for a size from an attribute definition clause). At this stage, this
6067       --  can happen only for types (e.g. record types) for which the size is
6068       --  always non-static. We exclude generic types from consideration (since
6069       --  they have bogus sizes set within templates).
6070
6071       elsif Id = Attribute_Size
6072         and then Is_Type (P_Entity)
6073         and then (not Is_Generic_Type (P_Entity))
6074         and then Known_Static_RM_Size (P_Entity)
6075       then
6076          Compile_Time_Known_Attribute (N, RM_Size (P_Entity));
6077          return;
6078
6079       --  We can fold 'Alignment applied to a type if the alignment is known
6080       --  (as happens for an alignment from an attribute definition clause).
6081       --  At this stage, this can happen only for types (e.g. record
6082       --  types) for which the size is always non-static. We exclude
6083       --  generic types from consideration (since they have bogus
6084       --  sizes set within templates).
6085
6086       elsif Id = Attribute_Alignment
6087         and then Is_Type (P_Entity)
6088         and then (not Is_Generic_Type (P_Entity))
6089         and then Known_Alignment (P_Entity)
6090       then
6091          Compile_Time_Known_Attribute (N, Alignment (P_Entity));
6092          return;
6093
6094       --  If this is an access attribute that is known to fail accessibility
6095       --  check, rewrite accordingly.
6096
6097       elsif Attribute_Name (N) = Name_Access
6098         and then Raises_Constraint_Error (N)
6099       then
6100          Rewrite (N,
6101            Make_Raise_Program_Error (Loc,
6102              Reason => PE_Accessibility_Check_Failed));
6103          Set_Etype (N, C_Type);
6104          return;
6105
6106       --  No other cases are foldable (they certainly aren't static, and at
6107       --  the moment we don't try to fold any cases other than the ones above).
6108
6109       else
6110          Check_Expressions;
6111          return;
6112       end if;
6113
6114       --  If either attribute or the prefix is Any_Type, then propagate
6115       --  Any_Type to the result and don't do anything else at all.
6116
6117       if P_Type = Any_Type
6118         or else (Present (E1) and then Etype (E1) = Any_Type)
6119         or else (Present (E2) and then Etype (E2) = Any_Type)
6120       then
6121          Set_Etype (N, Any_Type);
6122          return;
6123       end if;
6124
6125       --  Scalar subtype case. We have not yet enforced the static requirement
6126       --  of (RM 4.9(7)) and we don't intend to just yet, since there are cases
6127       --  of non-static attribute references (e.g. S'Digits for a non-static
6128       --  floating-point type, which we can compute at compile time).
6129
6130       --  Note: this folding of non-static attributes is not simply a case of
6131       --  optimization. For many of the attributes affected, Gigi cannot handle
6132       --  the attribute and depends on the front end having folded them away.
6133
6134       --  Note: although we don't require staticness at this stage, we do set
6135       --  the Static variable to record the staticness, for easy reference by
6136       --  those attributes where it matters (e.g. Succ and Pred), and also to
6137       --  be used to ensure that non-static folded things are not marked as
6138       --  being static (a check that is done right at the end).
6139
6140       P_Root_Type := Root_Type (P_Type);
6141       P_Base_Type := Base_Type (P_Type);
6142
6143       --  If the root type or base type is generic, then we cannot fold. This
6144       --  test is needed because subtypes of generic types are not always
6145       --  marked as being generic themselves (which seems odd???)
6146
6147       if Is_Generic_Type (P_Root_Type)
6148         or else Is_Generic_Type (P_Base_Type)
6149       then
6150          return;
6151       end if;
6152
6153       if Is_Scalar_Type (P_Type) then
6154          Static := Is_OK_Static_Subtype (P_Type);
6155
6156       --  Array case. We enforce the constrained requirement of (RM 4.9(7-8))
6157       --  since we can't do anything with unconstrained arrays. In addition,
6158       --  only the First, Last and Length attributes are possibly static.
6159
6160       --  Atomic_Always_Lock_Free, Definite, Has_Access_Values,
6161       --  Has_Discriminants, Has_Tagged_Values, Lock_Free, Type_Class, and
6162       --  Unconstrained_Array are again exceptions, because they apply as well
6163       --  to unconstrained types.
6164
6165       --  In addition Component_Size is an exception since it is possibly
6166       --  foldable, even though it is never static, and it does apply to
6167       --  unconstrained arrays. Furthermore, it is essential to fold this
6168       --  in the packed case, since otherwise the value will be incorrect.
6169
6170       elsif Id = Attribute_Atomic_Always_Lock_Free
6171               or else
6172             Id = Attribute_Definite
6173               or else
6174             Id = Attribute_Has_Access_Values
6175               or else
6176             Id = Attribute_Has_Discriminants
6177               or else
6178             Id = Attribute_Has_Tagged_Values
6179               or else
6180             Id = Attribute_Lock_Free
6181               or else
6182             Id = Attribute_Type_Class
6183               or else
6184             Id = Attribute_Unconstrained_Array
6185               or else
6186             Id = Attribute_Component_Size
6187       then
6188          Static := False;
6189
6190       elsif Id /= Attribute_Max_Alignment_For_Allocation then
6191          if not Is_Constrained (P_Type)
6192            or else (Id /= Attribute_First and then
6193                     Id /= Attribute_Last  and then
6194                     Id /= Attribute_Length)
6195          then
6196             Check_Expressions;
6197             return;
6198          end if;
6199
6200          --  The rules in (RM 4.9(7,8)) require a static array, but as in the
6201          --  scalar case, we hold off on enforcing staticness, since there are
6202          --  cases which we can fold at compile time even though they are not
6203          --  static (e.g. 'Length applied to a static index, even though other
6204          --  non-static indexes make the array type non-static). This is only
6205          --  an optimization, but it falls out essentially free, so why not.
6206          --  Again we compute the variable Static for easy reference later
6207          --  (note that no array attributes are static in Ada 83).
6208
6209          --  We also need to set Static properly for subsequent legality checks
6210          --  which might otherwise accept non-static constants in contexts
6211          --  where they are not legal.
6212
6213          Static := Ada_Version >= Ada_95
6214                      and then Statically_Denotes_Entity (P);
6215
6216          declare
6217             N : Node_Id;
6218
6219          begin
6220             N := First_Index (P_Type);
6221
6222             --  The expression is static if the array type is constrained
6223             --  by given bounds, and not by an initial expression. Constant
6224             --  strings are static in any case.
6225
6226             if Root_Type (P_Type) /= Standard_String then
6227                Static :=
6228                  Static and then not Is_Constr_Subt_For_U_Nominal (P_Type);
6229             end if;
6230
6231             while Present (N) loop
6232                Static := Static and then Is_Static_Subtype (Etype (N));
6233
6234                --  If however the index type is generic, or derived from
6235                --  one, attributes cannot be folded.
6236
6237                if Is_Generic_Type (Root_Type (Etype (N)))
6238                  and then Id /= Attribute_Component_Size
6239                then
6240                   return;
6241                end if;
6242
6243                Next_Index (N);
6244             end loop;
6245          end;
6246       end if;
6247
6248       --  Check any expressions that are present. Note that these expressions,
6249       --  depending on the particular attribute type, are either part of the
6250       --  attribute designator, or they are arguments in a case where the
6251       --  attribute reference returns a function. In the latter case, the
6252       --  rule in (RM 4.9(22)) applies and in particular requires the type
6253       --  of the expressions to be scalar in order for the attribute to be
6254       --  considered to be static.
6255
6256       declare
6257          E : Node_Id;
6258
6259       begin
6260          E := E1;
6261          while Present (E) loop
6262
6263             --  If expression is not static, then the attribute reference
6264             --  result certainly cannot be static.
6265
6266             if not Is_Static_Expression (E) then
6267                Static := False;
6268             end if;
6269
6270             --  If the result is not known at compile time, or is not of
6271             --  a scalar type, then the result is definitely not static,
6272             --  so we can quit now.
6273
6274             if not Compile_Time_Known_Value (E)
6275               or else not Is_Scalar_Type (Etype (E))
6276             then
6277                --  An odd special case, if this is a Pos attribute, this
6278                --  is where we need to apply a range check since it does
6279                --  not get done anywhere else.
6280
6281                if Id = Attribute_Pos then
6282                   if Is_Integer_Type (Etype (E)) then
6283                      Apply_Range_Check (E, Etype (N));
6284                   end if;
6285                end if;
6286
6287                Check_Expressions;
6288                return;
6289
6290             --  If the expression raises a constraint error, then so does
6291             --  the attribute reference. We keep going in this case because
6292             --  we are still interested in whether the attribute reference
6293             --  is static even if it is not static.
6294
6295             elsif Raises_Constraint_Error (E) then
6296                Set_Raises_Constraint_Error (N);
6297             end if;
6298
6299             Next (E);
6300          end loop;
6301
6302          if Raises_Constraint_Error (Prefix (N)) then
6303             return;
6304          end if;
6305       end;
6306
6307       --  Deal with the case of a static attribute reference that raises
6308       --  constraint error. The Raises_Constraint_Error flag will already
6309       --  have been set, and the Static flag shows whether the attribute
6310       --  reference is static. In any case we certainly can't fold such an
6311       --  attribute reference.
6312
6313       --  Note that the rewriting of the attribute node with the constraint
6314       --  error node is essential in this case, because otherwise Gigi might
6315       --  blow up on one of the attributes it never expects to see.
6316
6317       --  The constraint_error node must have the type imposed by the context,
6318       --  to avoid spurious errors in the enclosing expression.
6319
6320       if Raises_Constraint_Error (N) then
6321          CE_Node :=
6322            Make_Raise_Constraint_Error (Sloc (N),
6323              Reason => CE_Range_Check_Failed);
6324          Set_Etype (CE_Node, Etype (N));
6325          Set_Raises_Constraint_Error (CE_Node);
6326          Check_Expressions;
6327          Rewrite (N, Relocate_Node (CE_Node));
6328          Set_Is_Static_Expression (N, Static);
6329          return;
6330       end if;
6331
6332       --  At this point we have a potentially foldable attribute reference.
6333       --  If Static is set, then the attribute reference definitely obeys
6334       --  the requirements in (RM 4.9(7,8,22)), and it definitely can be
6335       --  folded. If Static is not set, then the attribute may or may not
6336       --  be foldable, and the individual attribute processing routines
6337       --  test Static as required in cases where it makes a difference.
6338
6339       --  In the case where Static is not set, we do know that all the
6340       --  expressions present are at least known at compile time (we assumed
6341       --  above that if this was not the case, then there was no hope of static
6342       --  evaluation). However, we did not require that the bounds of the
6343       --  prefix type be compile time known, let alone static). That's because
6344       --  there are many attributes that can be computed at compile time on
6345       --  non-static subtypes, even though such references are not static
6346       --  expressions.
6347
6348       case Id is
6349
6350          --  Attributes related to Ada 2012 iterators (placeholder ???)
6351
6352          when Attribute_Constant_Indexing    |
6353               Attribute_Default_Iterator     |
6354               Attribute_Implicit_Dereference |
6355               Attribute_Iterator_Element     |
6356               Attribute_Variable_Indexing    => null;
6357
6358          --  Internal attributes used to deal with Ada 2012 delayed aspects.
6359          --  These were already rejected by the parser. Thus they shouldn't
6360          --  appear here.
6361
6362          when Internal_Attribute_Id =>
6363             raise Program_Error;
6364
6365       --------------
6366       -- Adjacent --
6367       --------------
6368
6369       when Attribute_Adjacent =>
6370          Fold_Ureal (N,
6371            Eval_Fat.Adjacent
6372              (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
6373
6374       ---------
6375       -- Aft --
6376       ---------
6377
6378       when Attribute_Aft =>
6379          Fold_Uint (N, Aft_Value (P_Type), True);
6380
6381       ---------------
6382       -- Alignment --
6383       ---------------
6384
6385       when Attribute_Alignment => Alignment_Block : declare
6386          P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
6387
6388       begin
6389          --  Fold if alignment is set and not otherwise
6390
6391          if Known_Alignment (P_TypeA) then
6392             Fold_Uint (N, Alignment (P_TypeA), Is_Discrete_Type (P_TypeA));
6393          end if;
6394       end Alignment_Block;
6395
6396       ---------------
6397       -- AST_Entry --
6398       ---------------
6399
6400       --  Can only be folded in No_Ast_Handler case
6401
6402       when Attribute_AST_Entry =>
6403          if not Is_AST_Entry (P_Entity) then
6404             Rewrite (N,
6405               New_Occurrence_Of (RTE (RE_No_AST_Handler), Loc));
6406          else
6407             null;
6408          end if;
6409
6410       -----------------------------
6411       -- Atomic_Always_Lock_Free --
6412       -----------------------------
6413
6414       --  Atomic_Always_Lock_Free attribute is a Boolean, thus no need to fold
6415       --  here.
6416
6417       when Attribute_Atomic_Always_Lock_Free => Atomic_Always_Lock_Free :
6418       declare
6419          V : constant Entity_Id :=
6420                Boolean_Literals
6421                  (Support_Atomic_Primitives_On_Target
6422                    and then Support_Atomic_Primitives (P_Type));
6423
6424       begin
6425          Rewrite (N, New_Occurrence_Of (V, Loc));
6426
6427          --  Analyze and resolve as boolean. Note that this attribute is a
6428          --  static attribute in GNAT.
6429
6430          Analyze_And_Resolve (N, Standard_Boolean);
6431          Static := True;
6432       end Atomic_Always_Lock_Free;
6433
6434       ---------
6435       -- Bit --
6436       ---------
6437
6438       --  Bit can never be folded
6439
6440       when Attribute_Bit =>
6441          null;
6442
6443       ------------------
6444       -- Body_Version --
6445       ------------------
6446
6447       --  Body_version can never be static
6448
6449       when Attribute_Body_Version =>
6450          null;
6451
6452       -------------
6453       -- Ceiling --
6454       -------------
6455
6456       when Attribute_Ceiling =>
6457          Fold_Ureal (N,
6458            Eval_Fat.Ceiling (P_Root_Type, Expr_Value_R (E1)), Static);
6459
6460       --------------------
6461       -- Component_Size --
6462       --------------------
6463
6464       when Attribute_Component_Size =>
6465          if Known_Static_Component_Size (P_Type) then
6466             Fold_Uint (N, Component_Size (P_Type), False);
6467          end if;
6468
6469       -------------
6470       -- Compose --
6471       -------------
6472
6473       when Attribute_Compose =>
6474          Fold_Ureal (N,
6475            Eval_Fat.Compose
6476              (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)),
6477               Static);
6478
6479       -----------------
6480       -- Constrained --
6481       -----------------
6482
6483       --  Constrained is never folded for now, there may be cases that
6484       --  could be handled at compile time. To be looked at later.
6485
6486       when Attribute_Constrained =>
6487          null;
6488
6489       ---------------
6490       -- Copy_Sign --
6491       ---------------
6492
6493       when Attribute_Copy_Sign =>
6494          Fold_Ureal (N,
6495            Eval_Fat.Copy_Sign
6496              (P_Root_Type, Expr_Value_R (E1), Expr_Value_R (E2)), Static);
6497
6498       --------------
6499       -- Definite --
6500       --------------
6501
6502       when Attribute_Definite =>
6503          Rewrite (N, New_Occurrence_Of (
6504            Boolean_Literals (not Is_Indefinite_Subtype (P_Entity)), Loc));
6505          Analyze_And_Resolve (N, Standard_Boolean);
6506
6507       -----------
6508       -- Delta --
6509       -----------
6510
6511       when Attribute_Delta =>
6512          Fold_Ureal (N, Delta_Value (P_Type), True);
6513
6514       ------------
6515       -- Denorm --
6516       ------------
6517
6518       when Attribute_Denorm =>
6519          Fold_Uint
6520            (N, UI_From_Int (Boolean'Pos (Denorm_On_Target)), True);
6521
6522       ---------------------
6523       -- Descriptor_Size --
6524       ---------------------
6525
6526       when Attribute_Descriptor_Size =>
6527          null;
6528
6529       ------------
6530       -- Digits --
6531       ------------
6532
6533       when Attribute_Digits =>
6534          Fold_Uint (N, Digits_Value (P_Type), True);
6535
6536       ----------
6537       -- Emax --
6538       ----------
6539
6540       when Attribute_Emax =>
6541
6542          --  Ada 83 attribute is defined as (RM83 3.5.8)
6543
6544          --    T'Emax = 4 * T'Mantissa
6545
6546          Fold_Uint (N, 4 * Mantissa, True);
6547
6548       --------------
6549       -- Enum_Rep --
6550       --------------
6551
6552       when Attribute_Enum_Rep =>
6553
6554          --  For an enumeration type with a non-standard representation use
6555          --  the Enumeration_Rep field of the proper constant. Note that this
6556          --  will not work for types Character/Wide_[Wide-]Character, since no
6557          --  real entities are created for the enumeration literals, but that
6558          --  does not matter since these two types do not have non-standard
6559          --  representations anyway.
6560
6561          if Is_Enumeration_Type (P_Type)
6562            and then Has_Non_Standard_Rep (P_Type)
6563          then
6564             Fold_Uint (N, Enumeration_Rep (Expr_Value_E (E1)), Static);
6565
6566          --  For enumeration types with standard representations and all
6567          --  other cases (i.e. all integer and modular types), Enum_Rep
6568          --  is equivalent to Pos.
6569
6570          else
6571             Fold_Uint (N, Expr_Value (E1), Static);
6572          end if;
6573
6574       --------------
6575       -- Enum_Val --
6576       --------------
6577
6578       when Attribute_Enum_Val => Enum_Val : declare
6579          Lit : Node_Id;
6580
6581       begin
6582          --  We have something like Enum_Type'Enum_Val (23), so search for a
6583          --  corresponding value in the list of Enum_Rep values for the type.
6584
6585          Lit := First_Literal (P_Base_Type);
6586          loop
6587             if Enumeration_Rep (Lit) = Expr_Value (E1) then
6588                Fold_Uint (N, Enumeration_Pos (Lit), Static);
6589                exit;
6590             end if;
6591
6592             Next_Literal (Lit);
6593
6594             if No (Lit) then
6595                Apply_Compile_Time_Constraint_Error
6596                  (N, "no representation value matches",
6597                   CE_Range_Check_Failed,
6598                   Warn => not Static);
6599                exit;
6600             end if;
6601          end loop;
6602       end Enum_Val;
6603
6604       -------------
6605       -- Epsilon --
6606       -------------
6607
6608       when Attribute_Epsilon =>
6609
6610          --  Ada 83 attribute is defined as (RM83 3.5.8)
6611
6612          --    T'Epsilon = 2.0**(1 - T'Mantissa)
6613
6614          Fold_Ureal (N, Ureal_2 ** (1 - Mantissa), True);
6615
6616       --------------
6617       -- Exponent --
6618       --------------
6619
6620       when Attribute_Exponent =>
6621          Fold_Uint (N,
6622            Eval_Fat.Exponent (P_Root_Type, Expr_Value_R (E1)), Static);
6623
6624       -----------
6625       -- First --
6626       -----------
6627
6628       when Attribute_First => First_Attr :
6629       begin
6630          Set_Bounds;
6631
6632          if Compile_Time_Known_Value (Lo_Bound) then
6633             if Is_Real_Type (P_Type) then
6634                Fold_Ureal (N, Expr_Value_R (Lo_Bound), Static);
6635             else
6636                Fold_Uint  (N, Expr_Value (Lo_Bound), Static);
6637             end if;
6638
6639          --  Replace VAX Float_Type'First with a reference to the temporary
6640          --  which represents the low bound of the type. This transformation
6641          --  is needed since the back end cannot evaluate 'First on VAX.
6642
6643          elsif Is_VAX_Float (P_Type)
6644            and then Nkind (Lo_Bound) = N_Identifier
6645          then
6646             Rewrite (N, New_Reference_To (Entity (Lo_Bound), Sloc (N)));
6647             Analyze (N);
6648
6649          else
6650             Check_Concurrent_Discriminant (Lo_Bound);
6651          end if;
6652       end First_Attr;
6653
6654       -----------------
6655       -- First_Valid --
6656       -----------------
6657
6658       when Attribute_First_Valid => First_Valid :
6659       begin
6660          if Has_Predicates (P_Type)
6661            and then Present (Static_Predicate (P_Type))
6662          then
6663             declare
6664                FirstN : constant Node_Id := First (Static_Predicate (P_Type));
6665             begin
6666                if Nkind (FirstN) = N_Range then
6667                   Fold_Uint (N, Expr_Value (Low_Bound (FirstN)), Static);
6668                else
6669                   Fold_Uint (N, Expr_Value (FirstN), Static);
6670                end if;
6671             end;
6672
6673          else
6674             Set_Bounds;
6675             Fold_Uint (N, Expr_Value (Lo_Bound), Static);
6676          end if;
6677       end First_Valid;
6678
6679       -----------------
6680       -- Fixed_Value --
6681       -----------------
6682
6683       when Attribute_Fixed_Value =>
6684          null;
6685
6686       -----------
6687       -- Floor --
6688       -----------
6689
6690       when Attribute_Floor =>
6691          Fold_Ureal (N,
6692            Eval_Fat.Floor (P_Root_Type, Expr_Value_R (E1)), Static);
6693
6694       ----------
6695       -- Fore --
6696       ----------
6697
6698       when Attribute_Fore =>
6699          if Compile_Time_Known_Bounds (P_Type) then
6700             Fold_Uint (N, UI_From_Int (Fore_Value), Static);
6701          end if;
6702
6703       --------------
6704       -- Fraction --
6705       --------------
6706
6707       when Attribute_Fraction =>
6708          Fold_Ureal (N,
6709            Eval_Fat.Fraction (P_Root_Type, Expr_Value_R (E1)), Static);
6710
6711       -----------------------
6712       -- Has_Access_Values --
6713       -----------------------
6714
6715       when Attribute_Has_Access_Values =>
6716          Rewrite (N, New_Occurrence_Of
6717            (Boolean_Literals (Has_Access_Values (P_Root_Type)), Loc));
6718          Analyze_And_Resolve (N, Standard_Boolean);
6719
6720       -----------------------
6721       -- Has_Discriminants --
6722       -----------------------
6723
6724       when Attribute_Has_Discriminants =>
6725          Rewrite (N, New_Occurrence_Of (
6726            Boolean_Literals (Has_Discriminants (P_Entity)), Loc));
6727          Analyze_And_Resolve (N, Standard_Boolean);
6728
6729       -----------------------
6730       -- Has_Tagged_Values --
6731       -----------------------
6732
6733       when Attribute_Has_Tagged_Values =>
6734          Rewrite (N, New_Occurrence_Of
6735            (Boolean_Literals (Has_Tagged_Component (P_Root_Type)), Loc));
6736          Analyze_And_Resolve (N, Standard_Boolean);
6737
6738       --------------
6739       -- Identity --
6740       --------------
6741
6742       when Attribute_Identity =>
6743          null;
6744
6745       -----------
6746       -- Image --
6747       -----------
6748
6749       --  Image is a scalar attribute, but is never static, because it is
6750       --  not a static function (having a non-scalar argument (RM 4.9(22))
6751       --  However, we can constant-fold the image of an enumeration literal
6752       --  if names are available.
6753
6754       when Attribute_Image =>
6755          if Is_Entity_Name (E1)
6756            and then Ekind (Entity (E1)) = E_Enumeration_Literal
6757            and then not Discard_Names (First_Subtype (Etype (E1)))
6758            and then not Global_Discard_Names
6759          then
6760             declare
6761                Lit : constant Entity_Id := Entity (E1);
6762                Str : String_Id;
6763             begin
6764                Start_String;
6765                Get_Unqualified_Decoded_Name_String (Chars (Lit));
6766                Set_Casing (All_Upper_Case);
6767                Store_String_Chars (Name_Buffer (1 .. Name_Len));
6768                Str := End_String;
6769                Rewrite (N, Make_String_Literal (Loc, Strval => Str));
6770                Analyze_And_Resolve (N, Standard_String);
6771                Set_Is_Static_Expression (N, False);
6772             end;
6773          end if;
6774
6775       ---------
6776       -- Img --
6777       ---------
6778
6779       --  Img is a scalar attribute, but is never static, because it is
6780       --  not a static function (having a non-scalar argument (RM 4.9(22))
6781
6782       when Attribute_Img =>
6783          null;
6784
6785       -------------------
6786       -- Integer_Value --
6787       -------------------
6788
6789       --  We never try to fold Integer_Value (though perhaps we could???)
6790
6791       when Attribute_Integer_Value =>
6792          null;
6793
6794       -------------------
6795       -- Invalid_Value --
6796       -------------------
6797
6798       --  Invalid_Value is a scalar attribute that is never static, because
6799       --  the value is by design out of range.
6800
6801       when Attribute_Invalid_Value =>
6802          null;
6803
6804       -----------
6805       -- Large --
6806       -----------
6807
6808       when Attribute_Large =>
6809
6810          --  For fixed-point, we use the identity:
6811
6812          --    T'Large = (2.0**T'Mantissa - 1.0) * T'Small
6813
6814          if Is_Fixed_Point_Type (P_Type) then
6815             Rewrite (N,
6816               Make_Op_Multiply (Loc,
6817                 Left_Opnd =>
6818                   Make_Op_Subtract (Loc,
6819                     Left_Opnd =>
6820                       Make_Op_Expon (Loc,
6821                         Left_Opnd =>
6822                           Make_Real_Literal (Loc, Ureal_2),
6823                         Right_Opnd =>
6824                           Make_Attribute_Reference (Loc,
6825                             Prefix => P,
6826                             Attribute_Name => Name_Mantissa)),
6827                     Right_Opnd => Make_Real_Literal (Loc, Ureal_1)),
6828
6829                 Right_Opnd =>
6830                   Make_Real_Literal (Loc, Small_Value (Entity (P)))));
6831
6832             Analyze_And_Resolve (N, C_Type);
6833
6834          --  Floating-point (Ada 83 compatibility)
6835
6836          else
6837             --  Ada 83 attribute is defined as (RM83 3.5.8)
6838
6839             --    T'Large = 2.0**T'Emax * (1.0 - 2.0**(-T'Mantissa))
6840
6841             --  where
6842
6843             --    T'Emax = 4 * T'Mantissa
6844
6845             Fold_Ureal (N,
6846               Ureal_2 ** (4 * Mantissa) * (Ureal_1 - Ureal_2 ** (-Mantissa)),
6847               True);
6848          end if;
6849
6850       ---------------
6851       -- Lock_Free --
6852       ---------------
6853
6854       when Attribute_Lock_Free => Lock_Free : declare
6855          V : constant Entity_Id := Boolean_Literals (Uses_Lock_Free (P_Type));
6856
6857       begin
6858          Rewrite (N, New_Occurrence_Of (V, Loc));
6859
6860          --  Analyze and resolve as boolean. Note that this attribute is a
6861          --  static attribute in GNAT.
6862
6863          Analyze_And_Resolve (N, Standard_Boolean);
6864          Static := True;
6865       end Lock_Free;
6866
6867       ----------
6868       -- Last --
6869       ----------
6870
6871       when Attribute_Last => Last_Attr :
6872       begin
6873          Set_Bounds;
6874
6875          if Compile_Time_Known_Value (Hi_Bound) then
6876             if Is_Real_Type (P_Type) then
6877                Fold_Ureal (N, Expr_Value_R (Hi_Bound), Static);
6878             else
6879                Fold_Uint  (N, Expr_Value (Hi_Bound), Static);
6880             end if;
6881
6882          --  Replace VAX Float_Type'Last with a reference to the temporary
6883          --  which represents the high bound of the type. This transformation
6884          --  is needed since the back end cannot evaluate 'Last on VAX.
6885
6886          elsif Is_VAX_Float (P_Type)
6887            and then Nkind (Hi_Bound) = N_Identifier
6888          then
6889             Rewrite (N, New_Reference_To (Entity (Hi_Bound), Sloc (N)));
6890             Analyze (N);
6891
6892          else
6893             Check_Concurrent_Discriminant (Hi_Bound);
6894          end if;
6895       end Last_Attr;
6896
6897       ----------------
6898       -- Last_Valid --
6899       ----------------
6900
6901       when Attribute_Last_Valid => Last_Valid :
6902       begin
6903          if Has_Predicates (P_Type)
6904            and then Present (Static_Predicate (P_Type))
6905          then
6906             declare
6907                LastN : constant Node_Id := Last (Static_Predicate (P_Type));
6908             begin
6909                if Nkind (LastN) = N_Range then
6910                   Fold_Uint (N, Expr_Value (High_Bound (LastN)), Static);
6911                else
6912                   Fold_Uint (N, Expr_Value (LastN), Static);
6913                end if;
6914             end;
6915
6916          else
6917             Set_Bounds;
6918             Fold_Uint (N, Expr_Value (Hi_Bound), Static);
6919          end if;
6920       end Last_Valid;
6921
6922       ------------------
6923       -- Leading_Part --
6924       ------------------
6925
6926       when Attribute_Leading_Part =>
6927          Fold_Ureal (N,
6928            Eval_Fat.Leading_Part
6929              (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static);
6930
6931       ------------
6932       -- Length --
6933       ------------
6934
6935       when Attribute_Length => Length : declare
6936          Ind : Node_Id;
6937
6938       begin
6939          --  If any index type is a formal type, or derived from one, the
6940          --  bounds are not static. Treating them as static can produce
6941          --  spurious warnings or improper constant folding.
6942
6943          Ind := First_Index (P_Type);
6944          while Present (Ind) loop
6945             if Is_Generic_Type (Root_Type (Etype (Ind))) then
6946                return;
6947             end if;
6948
6949             Next_Index (Ind);
6950          end loop;
6951
6952          Set_Bounds;
6953
6954          --  For two compile time values, we can compute length
6955
6956          if Compile_Time_Known_Value (Lo_Bound)
6957            and then Compile_Time_Known_Value (Hi_Bound)
6958          then
6959             Fold_Uint (N,
6960               UI_Max (0, 1 + (Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound))),
6961               True);
6962          end if;
6963
6964          --  One more case is where Hi_Bound and Lo_Bound are compile-time
6965          --  comparable, and we can figure out the difference between them.
6966
6967          declare
6968             Diff : aliased Uint;
6969
6970          begin
6971             case
6972               Compile_Time_Compare
6973                 (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
6974             is
6975                when EQ =>
6976                   Fold_Uint (N, Uint_1, False);
6977
6978                when GT =>
6979                   Fold_Uint (N, Uint_0, False);
6980
6981                when LT =>
6982                   if Diff /= No_Uint then
6983                      Fold_Uint (N, Diff + 1, False);
6984                   end if;
6985
6986                when others =>
6987                   null;
6988             end case;
6989          end;
6990       end Length;
6991
6992       -------------
6993       -- Machine --
6994       -------------
6995
6996       when Attribute_Machine =>
6997          Fold_Ureal (N,
6998            Eval_Fat.Machine
6999              (P_Root_Type, Expr_Value_R (E1), Eval_Fat.Round, N),
7000            Static);
7001
7002       ------------------
7003       -- Machine_Emax --
7004       ------------------
7005
7006       when Attribute_Machine_Emax =>
7007          Fold_Uint (N, Machine_Emax_Value (P_Type), Static);
7008
7009       ------------------
7010       -- Machine_Emin --
7011       ------------------
7012
7013       when Attribute_Machine_Emin =>
7014          Fold_Uint (N, Machine_Emin_Value (P_Type), Static);
7015
7016       ----------------------
7017       -- Machine_Mantissa --
7018       ----------------------
7019
7020       when Attribute_Machine_Mantissa =>
7021          Fold_Uint (N, Machine_Mantissa_Value (P_Type), Static);
7022
7023       -----------------------
7024       -- Machine_Overflows --
7025       -----------------------
7026
7027       when Attribute_Machine_Overflows =>
7028
7029          --  Always true for fixed-point
7030
7031          if Is_Fixed_Point_Type (P_Type) then
7032             Fold_Uint (N, True_Value, True);
7033
7034          --  Floating point case
7035
7036          else
7037             Fold_Uint (N,
7038               UI_From_Int (Boolean'Pos (Machine_Overflows_On_Target)),
7039               True);
7040          end if;
7041
7042       -------------------
7043       -- Machine_Radix --
7044       -------------------
7045
7046       when Attribute_Machine_Radix =>
7047          if Is_Fixed_Point_Type (P_Type) then
7048             if Is_Decimal_Fixed_Point_Type (P_Type)
7049               and then Machine_Radix_10 (P_Type)
7050             then
7051                Fold_Uint (N, Uint_10, True);
7052             else
7053                Fold_Uint (N, Uint_2, True);
7054             end if;
7055
7056          --  All floating-point type always have radix 2
7057
7058          else
7059             Fold_Uint (N, Uint_2, True);
7060          end if;
7061
7062       ----------------------
7063       -- Machine_Rounding --
7064       ----------------------
7065
7066       --  Note: for the folding case, it is fine to treat Machine_Rounding
7067       --  exactly the same way as Rounding, since this is one of the allowed
7068       --  behaviors, and performance is not an issue here. It might be a bit
7069       --  better to give the same result as it would give at run time, even
7070       --  though the non-determinism is certainly permitted.
7071
7072       when Attribute_Machine_Rounding =>
7073          Fold_Ureal (N,
7074            Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static);
7075
7076       --------------------
7077       -- Machine_Rounds --
7078       --------------------
7079
7080       when Attribute_Machine_Rounds =>
7081
7082          --  Always False for fixed-point
7083
7084          if Is_Fixed_Point_Type (P_Type) then
7085             Fold_Uint (N, False_Value, True);
7086
7087          --  Else yield proper floating-point result
7088
7089          else
7090             Fold_Uint
7091               (N, UI_From_Int (Boolean'Pos (Machine_Rounds_On_Target)), True);
7092          end if;
7093
7094       ------------------
7095       -- Machine_Size --
7096       ------------------
7097
7098       --  Note: Machine_Size is identical to Object_Size
7099
7100       when Attribute_Machine_Size => Machine_Size : declare
7101          P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
7102
7103       begin
7104          if Known_Esize (P_TypeA) then
7105             Fold_Uint (N, Esize (P_TypeA), True);
7106          end if;
7107       end Machine_Size;
7108
7109       --------------
7110       -- Mantissa --
7111       --------------
7112
7113       when Attribute_Mantissa =>
7114
7115          --  Fixed-point mantissa
7116
7117          if Is_Fixed_Point_Type (P_Type) then
7118
7119             --  Compile time foldable case
7120
7121             if Compile_Time_Known_Value (Type_Low_Bound  (P_Type))
7122                  and then
7123                Compile_Time_Known_Value (Type_High_Bound (P_Type))
7124             then
7125                --  The calculation of the obsolete Ada 83 attribute Mantissa
7126                --  is annoying, because of AI00143, quoted here:
7127
7128                --  !question 84-01-10
7129
7130                --  Consider the model numbers for F:
7131
7132                --         type F is delta 1.0 range -7.0 .. 8.0;
7133
7134                --  The wording requires that F'MANTISSA be the SMALLEST
7135                --  integer number for which each  bound  of the specified
7136                --  range is either a model number or lies at most small
7137                --  distant from a model number. This means F'MANTISSA
7138                --  is required to be 3 since the range  -7.0 .. 7.0 fits
7139                --  in 3 signed bits, and 8 is "at most" 1.0 from a model
7140                --  number, namely, 7. Is this analysis correct? Note that
7141                --  this implies the upper bound of the range is not
7142                --  represented as a model number.
7143
7144                --  !response 84-03-17
7145
7146                --  The analysis is correct. The upper and lower bounds for
7147                --  a fixed  point type can lie outside the range of model
7148                --  numbers.
7149
7150                declare
7151                   Siz     : Uint;
7152                   LBound  : Ureal;
7153                   UBound  : Ureal;
7154                   Bound   : Ureal;
7155                   Max_Man : Uint;
7156
7157                begin
7158                   LBound  := Expr_Value_R (Type_Low_Bound  (P_Type));
7159                   UBound  := Expr_Value_R (Type_High_Bound (P_Type));
7160                   Bound   := UR_Max (UR_Abs (LBound), UR_Abs (UBound));
7161                   Max_Man := UR_Trunc (Bound / Small_Value (P_Type));
7162
7163                   --  If the Bound is exactly a model number, i.e. a multiple
7164                   --  of Small, then we back it off by one to get the integer
7165                   --  value that must be representable.
7166
7167                   if Small_Value (P_Type) * Max_Man = Bound then
7168                      Max_Man := Max_Man - 1;
7169                   end if;
7170
7171                   --  Now find corresponding size = Mantissa value
7172
7173                   Siz := Uint_0;
7174                   while 2 ** Siz < Max_Man loop
7175                      Siz := Siz + 1;
7176                   end loop;
7177
7178                   Fold_Uint (N, Siz, True);
7179                end;
7180
7181             else
7182                --  The case of dynamic bounds cannot be evaluated at compile
7183                --  time. Instead we use a runtime routine (see Exp_Attr).
7184
7185                null;
7186             end if;
7187
7188          --  Floating-point Mantissa
7189
7190          else
7191             Fold_Uint (N, Mantissa, True);
7192          end if;
7193
7194       ---------
7195       -- Max --
7196       ---------
7197
7198       when Attribute_Max => Max :
7199       begin
7200          if Is_Real_Type (P_Type) then
7201             Fold_Ureal
7202               (N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
7203          else
7204             Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static);
7205          end if;
7206       end Max;
7207
7208       ----------------------------------
7209       -- Max_Alignment_For_Allocation --
7210       ----------------------------------
7211
7212       --  Max_Alignment_For_Allocation is usually the Alignment. However,
7213       --  arrays are allocated with dope, so we need to take into account both
7214       --  the alignment of the array, which comes from the component alignment,
7215       --  and the alignment of the dope. Also, if the alignment is unknown, we
7216       --  use the max (it's OK to be pessimistic).
7217
7218       when Attribute_Max_Alignment_For_Allocation =>
7219          declare
7220             A : Uint := UI_From_Int (Ttypes.Maximum_Alignment);
7221          begin
7222             if Known_Alignment (P_Type) and then
7223               (not Is_Array_Type (P_Type) or else Alignment (P_Type) > A)
7224             then
7225                A := Alignment (P_Type);
7226             end if;
7227
7228             Fold_Uint (N, A, Static);
7229          end;
7230
7231       ----------------------------------
7232       -- Max_Size_In_Storage_Elements --
7233       ----------------------------------
7234
7235       --  Max_Size_In_Storage_Elements is simply the Size rounded up to a
7236       --  Storage_Unit boundary. We can fold any cases for which the size
7237       --  is known by the front end.
7238
7239       when Attribute_Max_Size_In_Storage_Elements =>
7240          if Known_Esize (P_Type) then
7241             Fold_Uint (N,
7242               (Esize (P_Type) + System_Storage_Unit - 1) /
7243                                           System_Storage_Unit,
7244                Static);
7245          end if;
7246
7247       --------------------
7248       -- Mechanism_Code --
7249       --------------------
7250
7251       when Attribute_Mechanism_Code =>
7252          declare
7253             Val    : Int;
7254             Formal : Entity_Id;
7255             Mech   : Mechanism_Type;
7256
7257          begin
7258             if No (E1) then
7259                Mech := Mechanism (P_Entity);
7260
7261             else
7262                Val := UI_To_Int (Expr_Value (E1));
7263
7264                Formal := First_Formal (P_Entity);
7265                for J in 1 .. Val - 1 loop
7266                   Next_Formal (Formal);
7267                end loop;
7268                Mech := Mechanism (Formal);
7269             end if;
7270
7271             if Mech < 0 then
7272                Fold_Uint (N, UI_From_Int (Int (-Mech)), True);
7273             end if;
7274          end;
7275
7276       ---------
7277       -- Min --
7278       ---------
7279
7280       when Attribute_Min => Min :
7281       begin
7282          if Is_Real_Type (P_Type) then
7283             Fold_Ureal
7284               (N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
7285          else
7286             Fold_Uint
7287               (N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static);
7288          end if;
7289       end Min;
7290
7291       ---------
7292       -- Mod --
7293       ---------
7294
7295       when Attribute_Mod =>
7296          Fold_Uint
7297            (N, UI_Mod (Expr_Value (E1), Modulus (P_Base_Type)), Static);
7298
7299       -----------
7300       -- Model --
7301       -----------
7302
7303       when Attribute_Model =>
7304          Fold_Ureal (N,
7305            Eval_Fat.Model (P_Root_Type, Expr_Value_R (E1)), Static);
7306
7307       ----------------
7308       -- Model_Emin --
7309       ----------------
7310
7311       when Attribute_Model_Emin =>
7312          Fold_Uint (N, Model_Emin_Value (P_Base_Type), Static);
7313
7314       -------------------
7315       -- Model_Epsilon --
7316       -------------------
7317
7318       when Attribute_Model_Epsilon =>
7319          Fold_Ureal (N, Model_Epsilon_Value (P_Base_Type), Static);
7320
7321       --------------------
7322       -- Model_Mantissa --
7323       --------------------
7324
7325       when Attribute_Model_Mantissa =>
7326          Fold_Uint (N, Model_Mantissa_Value (P_Base_Type), Static);
7327
7328       -----------------
7329       -- Model_Small --
7330       -----------------
7331
7332       when Attribute_Model_Small =>
7333          Fold_Ureal (N, Model_Small_Value (P_Base_Type), Static);
7334
7335       -------------
7336       -- Modulus --
7337       -------------
7338
7339       when Attribute_Modulus =>
7340          Fold_Uint (N, Modulus (P_Type), True);
7341
7342       --------------------
7343       -- Null_Parameter --
7344       --------------------
7345
7346       --  Cannot fold, we know the value sort of, but the whole point is
7347       --  that there is no way to talk about this imaginary value except
7348       --  by using the attribute, so we leave it the way it is.
7349
7350       when Attribute_Null_Parameter =>
7351          null;
7352
7353       -----------------
7354       -- Object_Size --
7355       -----------------
7356
7357       --  The Object_Size attribute for a type returns the Esize of the
7358       --  type and can be folded if this value is known.
7359
7360       when Attribute_Object_Size => Object_Size : declare
7361          P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
7362
7363       begin
7364          if Known_Esize (P_TypeA) then
7365             Fold_Uint (N, Esize (P_TypeA), True);
7366          end if;
7367       end Object_Size;
7368
7369       ----------------------
7370       -- Overlaps_Storage --
7371       ----------------------
7372
7373       when Attribute_Overlaps_Storage =>
7374          null;
7375
7376       -------------------------
7377       -- Passed_By_Reference --
7378       -------------------------
7379
7380       --  Scalar types are never passed by reference
7381
7382       when Attribute_Passed_By_Reference =>
7383          Fold_Uint (N, False_Value, True);
7384
7385       ---------
7386       -- Pos --
7387       ---------
7388
7389       when Attribute_Pos =>
7390          Fold_Uint (N, Expr_Value (E1), True);
7391
7392       ----------
7393       -- Pred --
7394       ----------
7395
7396       when Attribute_Pred => Pred :
7397       begin
7398          --  Floating-point case
7399
7400          if Is_Floating_Point_Type (P_Type) then
7401             Fold_Ureal (N,
7402               Eval_Fat.Pred (P_Root_Type, Expr_Value_R (E1)), Static);
7403
7404          --  Fixed-point case
7405
7406          elsif Is_Fixed_Point_Type (P_Type) then
7407             Fold_Ureal (N,
7408               Expr_Value_R (E1) - Small_Value (P_Type), True);
7409
7410          --  Modular integer case (wraps)
7411
7412          elsif Is_Modular_Integer_Type (P_Type) then
7413             Fold_Uint (N, (Expr_Value (E1) - 1) mod Modulus (P_Type), Static);
7414
7415          --  Other scalar cases
7416
7417          else
7418             pragma Assert (Is_Scalar_Type (P_Type));
7419
7420             if Is_Enumeration_Type (P_Type)
7421               and then Expr_Value (E1) =
7422                          Expr_Value (Type_Low_Bound (P_Base_Type))
7423             then
7424                Apply_Compile_Time_Constraint_Error
7425                  (N, "Pred of `&''First`",
7426                   CE_Overflow_Check_Failed,
7427                   Ent  => P_Base_Type,
7428                   Warn => not Static);
7429
7430                Check_Expressions;
7431                return;
7432             end if;
7433
7434             Fold_Uint (N, Expr_Value (E1) - 1, Static);
7435          end if;
7436       end Pred;
7437
7438       -----------
7439       -- Range --
7440       -----------
7441
7442       --  No processing required, because by this stage, Range has been
7443       --  replaced by First .. Last, so this branch can never be taken.
7444
7445       when Attribute_Range =>
7446          raise Program_Error;
7447
7448       ------------------
7449       -- Range_Length --
7450       ------------------
7451
7452       when Attribute_Range_Length =>
7453          Set_Bounds;
7454
7455          --  Can fold if both bounds are compile time known
7456
7457          if Compile_Time_Known_Value (Hi_Bound)
7458            and then Compile_Time_Known_Value (Lo_Bound)
7459          then
7460             Fold_Uint (N,
7461               UI_Max
7462                 (0, Expr_Value (Hi_Bound) - Expr_Value (Lo_Bound) + 1),
7463                  Static);
7464          end if;
7465
7466          --  One more case is where Hi_Bound and Lo_Bound are compile-time
7467          --  comparable, and we can figure out the difference between them.
7468
7469          declare
7470             Diff : aliased Uint;
7471
7472          begin
7473             case
7474               Compile_Time_Compare
7475                 (Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
7476             is
7477                when EQ =>
7478                   Fold_Uint (N, Uint_1, False);
7479
7480                when GT =>
7481                   Fold_Uint (N, Uint_0, False);
7482
7483                when LT =>
7484                   if Diff /= No_Uint then
7485                      Fold_Uint (N, Diff + 1, False);
7486                   end if;
7487
7488                when others =>
7489                   null;
7490             end case;
7491          end;
7492
7493       ---------
7494       -- Ref --
7495       ---------
7496
7497       when Attribute_Ref =>
7498          Fold_Uint (N, Expr_Value (E1), True);
7499
7500       ---------------
7501       -- Remainder --
7502       ---------------
7503
7504       when Attribute_Remainder => Remainder : declare
7505          X : constant Ureal := Expr_Value_R (E1);
7506          Y : constant Ureal := Expr_Value_R (E2);
7507
7508       begin
7509          if UR_Is_Zero (Y) then
7510             Apply_Compile_Time_Constraint_Error
7511               (N, "division by zero in Remainder",
7512                CE_Overflow_Check_Failed,
7513                Warn => not Static);
7514
7515             Check_Expressions;
7516             return;
7517          end if;
7518
7519          Fold_Ureal (N, Eval_Fat.Remainder (P_Root_Type, X, Y), Static);
7520       end Remainder;
7521
7522       -----------
7523       -- Round --
7524       -----------
7525
7526       when Attribute_Round => Round :
7527       declare
7528          Sr : Ureal;
7529          Si : Uint;
7530
7531       begin
7532          --  First we get the (exact result) in units of small
7533
7534          Sr := Expr_Value_R (E1) / Small_Value (C_Type);
7535
7536          --  Now round that exactly to an integer
7537
7538          Si := UR_To_Uint (Sr);
7539
7540          --  Finally the result is obtained by converting back to real
7541
7542          Fold_Ureal (N, Si * Small_Value (C_Type), Static);
7543       end Round;
7544
7545       --------------
7546       -- Rounding --
7547       --------------
7548
7549       when Attribute_Rounding =>
7550          Fold_Ureal (N,
7551            Eval_Fat.Rounding (P_Root_Type, Expr_Value_R (E1)), Static);
7552
7553       ---------------
7554       -- Safe_Emax --
7555       ---------------
7556
7557       when Attribute_Safe_Emax =>
7558          Fold_Uint (N, Safe_Emax_Value (P_Type), Static);
7559
7560       ----------------
7561       -- Safe_First --
7562       ----------------
7563
7564       when Attribute_Safe_First =>
7565          Fold_Ureal (N, Safe_First_Value (P_Type), Static);
7566
7567       ----------------
7568       -- Safe_Large --
7569       ----------------
7570
7571       when Attribute_Safe_Large =>
7572          if Is_Fixed_Point_Type (P_Type) then
7573             Fold_Ureal
7574               (N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static);
7575          else
7576             Fold_Ureal (N, Safe_Last_Value (P_Type), Static);
7577          end if;
7578
7579       ---------------
7580       -- Safe_Last --
7581       ---------------
7582
7583       when Attribute_Safe_Last =>
7584          Fold_Ureal (N, Safe_Last_Value (P_Type), Static);
7585
7586       ----------------
7587       -- Safe_Small --
7588       ----------------
7589
7590       when Attribute_Safe_Small =>
7591
7592          --  In Ada 95, the old Ada 83 attribute Safe_Small is redundant
7593          --  for fixed-point, since is the same as Small, but we implement
7594          --  it for backwards compatibility.
7595
7596          if Is_Fixed_Point_Type (P_Type) then
7597             Fold_Ureal (N, Small_Value (P_Type), Static);
7598
7599          --  Ada 83 Safe_Small for floating-point cases
7600
7601          else
7602             Fold_Ureal (N, Model_Small_Value (P_Type), Static);
7603          end if;
7604
7605       ------------------
7606       -- Same_Storage --
7607       ------------------
7608
7609       when Attribute_Same_Storage =>
7610          null;
7611
7612       -----------
7613       -- Scale --
7614       -----------
7615
7616       when Attribute_Scale =>
7617          Fold_Uint (N, Scale_Value (P_Type), True);
7618
7619       -------------
7620       -- Scaling --
7621       -------------
7622
7623       when Attribute_Scaling =>
7624          Fold_Ureal (N,
7625            Eval_Fat.Scaling
7626              (P_Root_Type, Expr_Value_R (E1), Expr_Value (E2)), Static);
7627
7628       ------------------
7629       -- Signed_Zeros --
7630       ------------------
7631
7632       when Attribute_Signed_Zeros =>
7633          Fold_Uint
7634            (N, UI_From_Int (Boolean'Pos (Signed_Zeros_On_Target)), Static);
7635
7636       ----------
7637       -- Size --
7638       ----------
7639
7640       --  Size attribute returns the RM size. All scalar types can be folded,
7641       --  as well as any types for which the size is known by the front end,
7642       --  including any type for which a size attribute is specified.
7643
7644       when Attribute_Size | Attribute_VADS_Size => Size : declare
7645          P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
7646
7647       begin
7648          if RM_Size (P_TypeA) /= Uint_0 then
7649
7650             --  VADS_Size case
7651
7652             if Id = Attribute_VADS_Size or else Use_VADS_Size then
7653                declare
7654                   S : constant Node_Id := Size_Clause (P_TypeA);
7655
7656                begin
7657                   --  If a size clause applies, then use the size from it.
7658                   --  This is one of the rare cases where we can use the
7659                   --  Size_Clause field for a subtype when Has_Size_Clause
7660                   --  is False. Consider:
7661
7662                   --    type x is range 1 .. 64;
7663                   --    for x'size use 12;
7664                   --    subtype y is x range 0 .. 3;
7665
7666                   --  Here y has a size clause inherited from x, but normally
7667                   --  it does not apply, and y'size is 2. However, y'VADS_Size
7668                   --  is indeed 12 and not 2.
7669
7670                   if Present (S)
7671                     and then Is_OK_Static_Expression (Expression (S))
7672                   then
7673                      Fold_Uint (N, Expr_Value (Expression (S)), True);
7674
7675                   --  If no size is specified, then we simply use the object
7676                   --  size in the VADS_Size case (e.g. Natural'Size is equal
7677                   --  to Integer'Size, not one less).
7678
7679                   else
7680                      Fold_Uint (N, Esize (P_TypeA), True);
7681                   end if;
7682                end;
7683
7684             --  Normal case (Size) in which case we want the RM_Size
7685
7686             else
7687                Fold_Uint (N,
7688                  RM_Size (P_TypeA),
7689                  Static and then Is_Discrete_Type (P_TypeA));
7690             end if;
7691          end if;
7692       end Size;
7693
7694       -----------
7695       -- Small --
7696       -----------
7697
7698       when Attribute_Small =>
7699
7700          --  The floating-point case is present only for Ada 83 compatibility.
7701          --  Note that strictly this is an illegal addition, since we are
7702          --  extending an Ada 95 defined attribute, but we anticipate an
7703          --  ARG ruling that will permit this.
7704
7705          if Is_Floating_Point_Type (P_Type) then
7706
7707             --  Ada 83 attribute is defined as (RM83 3.5.8)
7708
7709             --    T'Small = 2.0**(-T'Emax - 1)
7710
7711             --  where
7712
7713             --    T'Emax = 4 * T'Mantissa
7714
7715             Fold_Ureal (N, Ureal_2 ** ((-(4 * Mantissa)) - 1), Static);
7716
7717          --  Normal Ada 95 fixed-point case
7718
7719          else
7720             Fold_Ureal (N, Small_Value (P_Type), True);
7721          end if;
7722
7723       -----------------
7724       -- Stream_Size --
7725       -----------------
7726
7727       when Attribute_Stream_Size =>
7728          null;
7729
7730       ----------
7731       -- Succ --
7732       ----------
7733
7734       when Attribute_Succ => Succ :
7735       begin
7736          --  Floating-point case
7737
7738          if Is_Floating_Point_Type (P_Type) then
7739             Fold_Ureal (N,
7740               Eval_Fat.Succ (P_Root_Type, Expr_Value_R (E1)), Static);
7741
7742          --  Fixed-point case
7743
7744          elsif Is_Fixed_Point_Type (P_Type) then
7745             Fold_Ureal (N,
7746               Expr_Value_R (E1) + Small_Value (P_Type), Static);
7747
7748          --  Modular integer case (wraps)
7749
7750          elsif Is_Modular_Integer_Type (P_Type) then
7751             Fold_Uint (N, (Expr_Value (E1) + 1) mod Modulus (P_Type), Static);
7752
7753          --  Other scalar cases
7754
7755          else
7756             pragma Assert (Is_Scalar_Type (P_Type));
7757
7758             if Is_Enumeration_Type (P_Type)
7759               and then Expr_Value (E1) =
7760                          Expr_Value (Type_High_Bound (P_Base_Type))
7761             then
7762                Apply_Compile_Time_Constraint_Error
7763                  (N, "Succ of `&''Last`",
7764                   CE_Overflow_Check_Failed,
7765                   Ent  => P_Base_Type,
7766                   Warn => not Static);
7767
7768                Check_Expressions;
7769                return;
7770             else
7771                Fold_Uint (N, Expr_Value (E1) + 1, Static);
7772             end if;
7773          end if;
7774       end Succ;
7775
7776       ----------------
7777       -- Truncation --
7778       ----------------
7779
7780       when Attribute_Truncation =>
7781          Fold_Ureal (N,
7782            Eval_Fat.Truncation (P_Root_Type, Expr_Value_R (E1)), Static);
7783
7784       ----------------
7785       -- Type_Class --
7786       ----------------
7787
7788       when Attribute_Type_Class => Type_Class : declare
7789          Typ : constant Entity_Id := Underlying_Type (P_Base_Type);
7790          Id  : RE_Id;
7791
7792       begin
7793          if Is_Descendent_Of_Address (Typ) then
7794             Id := RE_Type_Class_Address;
7795
7796          elsif Is_Enumeration_Type (Typ) then
7797             Id := RE_Type_Class_Enumeration;
7798
7799          elsif Is_Integer_Type (Typ) then
7800             Id := RE_Type_Class_Integer;
7801
7802          elsif Is_Fixed_Point_Type (Typ) then
7803             Id := RE_Type_Class_Fixed_Point;
7804
7805          elsif Is_Floating_Point_Type (Typ) then
7806             Id := RE_Type_Class_Floating_Point;
7807
7808          elsif Is_Array_Type (Typ) then
7809             Id := RE_Type_Class_Array;
7810
7811          elsif Is_Record_Type (Typ) then
7812             Id := RE_Type_Class_Record;
7813
7814          elsif Is_Access_Type (Typ) then
7815             Id := RE_Type_Class_Access;
7816
7817          elsif Is_Enumeration_Type (Typ) then
7818             Id := RE_Type_Class_Enumeration;
7819
7820          elsif Is_Task_Type (Typ) then
7821             Id := RE_Type_Class_Task;
7822
7823          --  We treat protected types like task types. It would make more
7824          --  sense to have another enumeration value, but after all the
7825          --  whole point of this feature is to be exactly DEC compatible,
7826          --  and changing the type Type_Class would not meet this requirement.
7827
7828          elsif Is_Protected_Type (Typ) then
7829             Id := RE_Type_Class_Task;
7830
7831          --  Not clear if there are any other possibilities, but if there
7832          --  are, then we will treat them as the address case.
7833
7834          else
7835             Id := RE_Type_Class_Address;
7836          end if;
7837
7838          Rewrite (N, New_Occurrence_Of (RTE (Id), Loc));
7839       end Type_Class;
7840
7841       -----------------------
7842       -- Unbiased_Rounding --
7843       -----------------------
7844
7845       when Attribute_Unbiased_Rounding =>
7846          Fold_Ureal (N,
7847            Eval_Fat.Unbiased_Rounding (P_Root_Type, Expr_Value_R (E1)),
7848            Static);
7849
7850       -------------------------
7851       -- Unconstrained_Array --
7852       -------------------------
7853
7854       when Attribute_Unconstrained_Array => Unconstrained_Array : declare
7855          Typ : constant Entity_Id := Underlying_Type (P_Type);
7856
7857       begin
7858          Rewrite (N, New_Occurrence_Of (
7859            Boolean_Literals (
7860              Is_Array_Type (P_Type)
7861               and then not Is_Constrained (Typ)), Loc));
7862
7863          --  Analyze and resolve as boolean, note that this attribute is
7864          --  a static attribute in GNAT.
7865
7866          Analyze_And_Resolve (N, Standard_Boolean);
7867          Static := True;
7868       end Unconstrained_Array;
7869
7870       ---------------
7871       -- VADS_Size --
7872       ---------------
7873
7874       --  Processing is shared with Size
7875
7876       ---------
7877       -- Val --
7878       ---------
7879
7880       when Attribute_Val => Val :
7881       begin
7882          if  Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type))
7883            or else
7884              Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type))
7885          then
7886             Apply_Compile_Time_Constraint_Error
7887               (N, "Val expression out of range",
7888                CE_Range_Check_Failed,
7889                Warn => not Static);
7890
7891             Check_Expressions;
7892             return;
7893
7894          else
7895             Fold_Uint (N, Expr_Value (E1), Static);
7896          end if;
7897       end Val;
7898
7899       ----------------
7900       -- Value_Size --
7901       ----------------
7902
7903       --  The Value_Size attribute for a type returns the RM size of the
7904       --  type. This an always be folded for scalar types, and can also
7905       --  be folded for non-scalar types if the size is set.
7906
7907       when Attribute_Value_Size => Value_Size : declare
7908          P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
7909       begin
7910          if RM_Size (P_TypeA) /= Uint_0 then
7911             Fold_Uint (N, RM_Size (P_TypeA), True);
7912          end if;
7913       end Value_Size;
7914
7915       -------------
7916       -- Version --
7917       -------------
7918
7919       --  Version can never be static
7920
7921       when Attribute_Version =>
7922          null;
7923
7924       ----------------
7925       -- Wide_Image --
7926       ----------------
7927
7928       --  Wide_Image is a scalar attribute, but is never static, because it
7929       --  is not a static function (having a non-scalar argument (RM 4.9(22))
7930
7931       when Attribute_Wide_Image =>
7932          null;
7933
7934       ---------------------
7935       -- Wide_Wide_Image --
7936       ---------------------
7937
7938       --  Wide_Wide_Image is a scalar attribute but is never static, because it
7939       --  is not a static function (having a non-scalar argument (RM 4.9(22)).
7940
7941       when Attribute_Wide_Wide_Image =>
7942          null;
7943
7944       ---------------------
7945       -- Wide_Wide_Width --
7946       ---------------------
7947
7948       --  Processing for Wide_Wide_Width is combined with Width
7949
7950       ----------------
7951       -- Wide_Width --
7952       ----------------
7953
7954       --  Processing for Wide_Width is combined with Width
7955
7956       -----------
7957       -- Width --
7958       -----------
7959
7960       --  This processing also handles the case of Wide_[Wide_]Width
7961
7962       when Attribute_Width |
7963            Attribute_Wide_Width |
7964            Attribute_Wide_Wide_Width => Width :
7965       begin
7966          if Compile_Time_Known_Bounds (P_Type) then
7967
7968             --  Floating-point types
7969
7970             if Is_Floating_Point_Type (P_Type) then
7971
7972                --  Width is zero for a null range (RM 3.5 (38))
7973
7974                if Expr_Value_R (Type_High_Bound (P_Type)) <
7975                   Expr_Value_R (Type_Low_Bound (P_Type))
7976                then
7977                   Fold_Uint (N, Uint_0, True);
7978
7979                else
7980                   --  For floating-point, we have +N.dddE+nnn where length
7981                   --  of ddd is determined by type'Digits - 1, but is one
7982                   --  if Digits is one (RM 3.5 (33)).
7983
7984                   --  nnn is set to 2 for Short_Float and Float (32 bit
7985                   --  floats), and 3 for Long_Float and Long_Long_Float.
7986                   --  For machines where Long_Long_Float is the IEEE
7987                   --  extended precision type, the exponent takes 4 digits.
7988
7989                   declare
7990                      Len : Int :=
7991                              Int'Max (2, UI_To_Int (Digits_Value (P_Type)));
7992
7993                   begin
7994                      if Esize (P_Type) <= 32 then
7995                         Len := Len + 6;
7996                      elsif Esize (P_Type) = 64 then
7997                         Len := Len + 7;
7998                      else
7999                         Len := Len + 8;
8000                      end if;
8001
8002                      Fold_Uint (N, UI_From_Int (Len), True);
8003                   end;
8004                end if;
8005
8006             --  Fixed-point types
8007
8008             elsif Is_Fixed_Point_Type (P_Type) then
8009
8010                --  Width is zero for a null range (RM 3.5 (38))
8011
8012                if Expr_Value (Type_High_Bound (P_Type)) <
8013                   Expr_Value (Type_Low_Bound  (P_Type))
8014                then
8015                   Fold_Uint (N, Uint_0, True);
8016
8017                --  The non-null case depends on the specific real type
8018
8019                else
8020                   --  For fixed-point type width is Fore + 1 + Aft (RM 3.5(34))
8021
8022                   Fold_Uint
8023                     (N, UI_From_Int (Fore_Value + 1) + Aft_Value (P_Type),
8024                      True);
8025                end if;
8026
8027             --  Discrete types
8028
8029             else
8030                declare
8031                   R  : constant Entity_Id := Root_Type (P_Type);
8032                   Lo : constant Uint := Expr_Value (Type_Low_Bound (P_Type));
8033                   Hi : constant Uint := Expr_Value (Type_High_Bound (P_Type));
8034                   W  : Nat;
8035                   Wt : Nat;
8036                   T  : Uint;
8037                   L  : Node_Id;
8038                   C  : Character;
8039
8040                begin
8041                   --  Empty ranges
8042
8043                   if Lo > Hi then
8044                      W := 0;
8045
8046                   --  Width for types derived from Standard.Character
8047                   --  and Standard.Wide_[Wide_]Character.
8048
8049                   elsif Is_Standard_Character_Type (P_Type) then
8050                      W := 0;
8051
8052                      --  Set W larger if needed
8053
8054                      for J in UI_To_Int (Lo) .. UI_To_Int (Hi) loop
8055
8056                         --  All wide characters look like Hex_hhhhhhhh
8057
8058                         if J > 255 then
8059
8060                            --  No need to compute this more than once!
8061
8062                            exit;
8063
8064                         else
8065                            C := Character'Val (J);
8066
8067                            --  Test for all cases where Character'Image
8068                            --  yields an image that is longer than three
8069                            --  characters. First the cases of Reserved_xxx
8070                            --  names (length = 12).
8071
8072                            case C is
8073                               when Reserved_128 | Reserved_129 |
8074                                    Reserved_132 | Reserved_153
8075                                 => Wt := 12;
8076
8077                               when BS | HT | LF | VT | FF | CR |
8078                                    SO | SI | EM | FS | GS | RS |
8079                                    US | RI | MW | ST | PM
8080                                 => Wt := 2;
8081
8082                               when NUL | SOH | STX | ETX | EOT |
8083                                    ENQ | ACK | BEL | DLE | DC1 |
8084                                    DC2 | DC3 | DC4 | NAK | SYN |
8085                                    ETB | CAN | SUB | ESC | DEL |
8086                                    BPH | NBH | NEL | SSA | ESA |
8087                                    HTS | HTJ | VTS | PLD | PLU |
8088                                    SS2 | SS3 | DCS | PU1 | PU2 |
8089                                    STS | CCH | SPA | EPA | SOS |
8090                                    SCI | CSI | OSC | APC
8091                                 => Wt := 3;
8092
8093                               when Space .. Tilde |
8094                                    No_Break_Space .. LC_Y_Diaeresis
8095                                 =>
8096                                  --  Special case of soft hyphen in Ada 2005
8097
8098                                  if C = Character'Val (16#AD#)
8099                                    and then Ada_Version >= Ada_2005
8100                                  then
8101                                     Wt := 11;
8102                                  else
8103                                     Wt := 3;
8104                                  end if;
8105                            end case;
8106
8107                            W := Int'Max (W, Wt);
8108                         end if;
8109                      end loop;
8110
8111                   --  Width for types derived from Standard.Boolean
8112
8113                   elsif R = Standard_Boolean then
8114                      if Lo = 0 then
8115                         W := 5; -- FALSE
8116                      else
8117                         W := 4; -- TRUE
8118                      end if;
8119
8120                   --  Width for integer types
8121
8122                   elsif Is_Integer_Type (P_Type) then
8123                      T := UI_Max (abs Lo, abs Hi);
8124
8125                      W := 2;
8126                      while T >= 10 loop
8127                         W := W + 1;
8128                         T := T / 10;
8129                      end loop;
8130
8131                   --  User declared enum type with discard names
8132
8133                   elsif Discard_Names (R) then
8134
8135                      --  If range is null, result is zero, that has already
8136                      --  been dealt with, so what we need is the power of ten
8137                      --  that accomodates the Pos of the largest value, which
8138                      --  is the high bound of the range + one for the space.
8139
8140                      W := 1;
8141                      T := Hi;
8142                      while T /= 0 loop
8143                         T := T / 10;
8144                         W := W + 1;
8145                      end loop;
8146
8147                   --  Only remaining possibility is user declared enum type
8148                   --  with normal case of Discard_Names not active.
8149
8150                   else
8151                      pragma Assert (Is_Enumeration_Type (P_Type));
8152
8153                      W := 0;
8154                      L := First_Literal (P_Type);
8155                      while Present (L) loop
8156
8157                         --  Only pay attention to in range characters
8158
8159                         if Lo <= Enumeration_Pos (L)
8160                           and then Enumeration_Pos (L) <= Hi
8161                         then
8162                            --  For Width case, use decoded name
8163
8164                            if Id = Attribute_Width then
8165                               Get_Decoded_Name_String (Chars (L));
8166                               Wt := Nat (Name_Len);
8167
8168                            --  For Wide_[Wide_]Width, use encoded name, and
8169                            --  then adjust for the encoding.
8170
8171                            else
8172                               Get_Name_String (Chars (L));
8173
8174                               --  Character literals are always of length 3
8175
8176                               if Name_Buffer (1) = 'Q' then
8177                                  Wt := 3;
8178
8179                               --  Otherwise loop to adjust for upper/wide chars
8180
8181                               else
8182                                  Wt := Nat (Name_Len);
8183
8184                                  for J in 1 .. Name_Len loop
8185                                     if Name_Buffer (J) = 'U' then
8186                                        Wt := Wt - 2;
8187                                     elsif Name_Buffer (J) = 'W' then
8188                                        Wt := Wt - 4;
8189                                     end if;
8190                                  end loop;
8191                               end if;
8192                            end if;
8193
8194                            W := Int'Max (W, Wt);
8195                         end if;
8196
8197                         Next_Literal (L);
8198                      end loop;
8199                   end if;
8200
8201                   Fold_Uint (N, UI_From_Int (W), True);
8202                end;
8203             end if;
8204          end if;
8205       end Width;
8206
8207       --  The following attributes denote functions that cannot be folded
8208
8209       when Attribute_From_Any |
8210            Attribute_To_Any   |
8211            Attribute_TypeCode =>
8212          null;
8213
8214       --  The following attributes can never be folded, and furthermore we
8215       --  should not even have entered the case statement for any of these.
8216       --  Note that in some cases, the values have already been folded as
8217       --  a result of the processing in Analyze_Attribute.
8218
8219       when Attribute_Abort_Signal               |
8220            Attribute_Access                     |
8221            Attribute_Address                    |
8222            Attribute_Address_Size               |
8223            Attribute_Asm_Input                  |
8224            Attribute_Asm_Output                 |
8225            Attribute_Base                       |
8226            Attribute_Bit_Order                  |
8227            Attribute_Bit_Position               |
8228            Attribute_Callable                   |
8229            Attribute_Caller                     |
8230            Attribute_Class                      |
8231            Attribute_Code_Address               |
8232            Attribute_Compiler_Version           |
8233            Attribute_Count                      |
8234            Attribute_Default_Bit_Order          |
8235            Attribute_Elaborated                 |
8236            Attribute_Elab_Body                  |
8237            Attribute_Elab_Spec                  |
8238            Attribute_Elab_Subp_Body             |
8239            Attribute_Enabled                    |
8240            Attribute_External_Tag               |
8241            Attribute_Fast_Math                  |
8242            Attribute_First_Bit                  |
8243            Attribute_Input                      |
8244            Attribute_Last_Bit                   |
8245            Attribute_Maximum_Alignment          |
8246            Attribute_Old                        |
8247            Attribute_Output                     |
8248            Attribute_Partition_ID               |
8249            Attribute_Pool_Address               |
8250            Attribute_Position                   |
8251            Attribute_Priority                   |
8252            Attribute_Read                       |
8253            Attribute_Result                     |
8254            Attribute_Scalar_Storage_Order       |
8255            Attribute_Simple_Storage_Pool        |
8256            Attribute_Storage_Pool               |
8257            Attribute_Storage_Size               |
8258            Attribute_Storage_Unit               |
8259            Attribute_Stub_Type                  |
8260            Attribute_System_Allocator_Alignment |
8261            Attribute_Tag                        |
8262            Attribute_Target_Name                |
8263            Attribute_Terminated                 |
8264            Attribute_To_Address                 |
8265            Attribute_Type_Key                   |
8266            Attribute_UET_Address                |
8267            Attribute_Unchecked_Access           |
8268            Attribute_Universal_Literal_String   |
8269            Attribute_Unrestricted_Access        |
8270            Attribute_Valid                      |
8271            Attribute_Valid_Scalars              |
8272            Attribute_Value                      |
8273            Attribute_Wchar_T_Size               |
8274            Attribute_Wide_Value                 |
8275            Attribute_Wide_Wide_Value            |
8276            Attribute_Word_Size                  |
8277            Attribute_Write                      =>
8278
8279          raise Program_Error;
8280       end case;
8281
8282       --  At the end of the case, one more check. If we did a static evaluation
8283       --  so that the result is now a literal, then set Is_Static_Expression
8284       --  in the constant only if the prefix type is a static subtype. For
8285       --  non-static subtypes, the folding is still OK, but not static.
8286
8287       --  An exception is the GNAT attribute Constrained_Array which is
8288       --  defined to be a static attribute in all cases.
8289
8290       if Nkind_In (N, N_Integer_Literal,
8291                       N_Real_Literal,
8292                       N_Character_Literal,
8293                       N_String_Literal)
8294         or else (Is_Entity_Name (N)
8295                   and then Ekind (Entity (N)) = E_Enumeration_Literal)
8296       then
8297          Set_Is_Static_Expression (N, Static);
8298
8299       --  If this is still an attribute reference, then it has not been folded
8300       --  and that means that its expressions are in a non-static context.
8301
8302       elsif Nkind (N) = N_Attribute_Reference then
8303          Check_Expressions;
8304
8305       --  Note: the else case not covered here are odd cases where the
8306       --  processing has transformed the attribute into something other
8307       --  than a constant. Nothing more to do in such cases.
8308
8309       else
8310          null;
8311       end if;
8312    end Eval_Attribute;
8313
8314    ------------------------------
8315    -- Is_Anonymous_Tagged_Base --
8316    ------------------------------
8317
8318    function Is_Anonymous_Tagged_Base
8319      (Anon : Entity_Id;
8320       Typ  : Entity_Id)
8321       return Boolean
8322    is
8323    begin
8324       return
8325         Anon = Current_Scope
8326           and then Is_Itype (Anon)
8327           and then Associated_Node_For_Itype (Anon) = Parent (Typ);
8328    end Is_Anonymous_Tagged_Base;
8329
8330    --------------------------------
8331    -- Name_Implies_Lvalue_Prefix --
8332    --------------------------------
8333
8334    function Name_Implies_Lvalue_Prefix (Nam : Name_Id) return Boolean is
8335       pragma Assert (Is_Attribute_Name (Nam));
8336    begin
8337       return Attribute_Name_Implies_Lvalue_Prefix (Get_Attribute_Id (Nam));
8338    end Name_Implies_Lvalue_Prefix;
8339
8340    -----------------------
8341    -- Resolve_Attribute --
8342    -----------------------
8343
8344    procedure Resolve_Attribute (N : Node_Id; Typ : Entity_Id) is
8345       Loc      : constant Source_Ptr   := Sloc (N);
8346       P        : constant Node_Id      := Prefix (N);
8347       Aname    : constant Name_Id      := Attribute_Name (N);
8348       Attr_Id  : constant Attribute_Id := Get_Attribute_Id (Aname);
8349       Btyp     : constant Entity_Id    := Base_Type (Typ);
8350       Des_Btyp : Entity_Id;
8351       Index    : Interp_Index;
8352       It       : Interp;
8353       Nom_Subt : Entity_Id;
8354
8355       procedure Accessibility_Message;
8356       --  Error, or warning within an instance, if the static accessibility
8357       --  rules of 3.10.2 are violated.
8358
8359       ---------------------------
8360       -- Accessibility_Message --
8361       ---------------------------
8362
8363       procedure Accessibility_Message is
8364          Indic : Node_Id := Parent (Parent (N));
8365
8366       begin
8367          --  In an instance, this is a runtime check, but one we
8368          --  know will fail, so generate an appropriate warning.
8369
8370          if In_Instance_Body then
8371             Error_Msg_F ("?non-local pointer cannot point to local object", P);
8372             Error_Msg_F
8373               ("\?Program_Error will be raised at run time", P);
8374             Rewrite (N,
8375               Make_Raise_Program_Error (Loc,
8376                 Reason => PE_Accessibility_Check_Failed));
8377             Set_Etype (N, Typ);
8378             return;
8379
8380          else
8381             Error_Msg_F ("non-local pointer cannot point to local object", P);
8382
8383             --  Check for case where we have a missing access definition
8384
8385             if Is_Record_Type (Current_Scope)
8386               and then
8387                 Nkind_In (Parent (N), N_Discriminant_Association,
8388                                       N_Index_Or_Discriminant_Constraint)
8389             then
8390                Indic := Parent (Parent (N));
8391                while Present (Indic)
8392                  and then Nkind (Indic) /= N_Subtype_Indication
8393                loop
8394                   Indic := Parent (Indic);
8395                end loop;
8396
8397                if Present (Indic) then
8398                   Error_Msg_NE
8399                     ("\use an access definition for" &
8400                      " the access discriminant of&",
8401                      N, Entity (Subtype_Mark (Indic)));
8402                end if;
8403             end if;
8404          end if;
8405       end Accessibility_Message;
8406
8407    --  Start of processing for Resolve_Attribute
8408
8409    begin
8410       --  If error during analysis, no point in continuing, except for array
8411       --  types, where we get better recovery by using unconstrained indexes
8412       --  than nothing at all (see Check_Array_Type).
8413
8414       if Error_Posted (N)
8415         and then Attr_Id /= Attribute_First
8416         and then Attr_Id /= Attribute_Last
8417         and then Attr_Id /= Attribute_Length
8418         and then Attr_Id /= Attribute_Range
8419       then
8420          return;
8421       end if;
8422
8423       --  If attribute was universal type, reset to actual type
8424
8425       if Etype (N) = Universal_Integer
8426         or else Etype (N) = Universal_Real
8427       then
8428          Set_Etype (N, Typ);
8429       end if;
8430
8431       --  Remaining processing depends on attribute
8432
8433       case Attr_Id is
8434
8435          ------------
8436          -- Access --
8437          ------------
8438
8439          --  For access attributes, if the prefix denotes an entity, it is
8440          --  interpreted as a name, never as a call. It may be overloaded,
8441          --  in which case resolution uses the profile of the context type.
8442          --  Otherwise prefix must be resolved.
8443
8444          when Attribute_Access
8445             | Attribute_Unchecked_Access
8446             | Attribute_Unrestricted_Access =>
8447
8448          Access_Attribute :
8449          begin
8450             if Is_Variable (P) then
8451                Note_Possible_Modification (P, Sure => False);
8452             end if;
8453
8454             --  The following comes from a query by Adam Beneschan, concerning
8455             --  improper use of universal_access in equality tests involving
8456             --  anonymous access types. Another good reason for 'Ref, but
8457             --  for now disable the test, which breaks several filed tests.
8458
8459             if Ekind (Typ) = E_Anonymous_Access_Type
8460               and then Nkind_In (Parent (N), N_Op_Eq, N_Op_Ne)
8461               and then False
8462             then
8463                Error_Msg_N ("need unique type to resolve 'Access", N);
8464                Error_Msg_N ("\qualify attribute with some access type", N);
8465             end if;
8466
8467             if Is_Entity_Name (P) then
8468                if Is_Overloaded (P) then
8469                   Get_First_Interp (P, Index, It);
8470                   while Present (It.Nam) loop
8471                      if Type_Conformant (Designated_Type (Typ), It.Nam) then
8472                         Set_Entity (P, It.Nam);
8473
8474                         --  The prefix is definitely NOT overloaded anymore at
8475                         --  this point, so we reset the Is_Overloaded flag to
8476                         --  avoid any confusion when reanalyzing the node.
8477
8478                         Set_Is_Overloaded (P, False);
8479                         Set_Is_Overloaded (N, False);
8480                         Generate_Reference (Entity (P), P);
8481                         exit;
8482                      end if;
8483
8484                      Get_Next_Interp (Index, It);
8485                   end loop;
8486
8487                --  If Prefix is a subprogram name, it is frozen by this
8488                --  reference:
8489
8490                --    If it is a type, there is nothing to resolve.
8491                --    If it is an object, complete its resolution.
8492
8493                elsif Is_Overloadable (Entity (P)) then
8494
8495                   --  Avoid insertion of freeze actions in spec expression mode
8496
8497                   if not In_Spec_Expression then
8498                      Freeze_Before (N, Entity (P));
8499                   end if;
8500
8501                elsif Is_Type (Entity (P)) then
8502                   null;
8503                else
8504                   Resolve (P);
8505                end if;
8506
8507                Error_Msg_Name_1 := Aname;
8508
8509                if not Is_Entity_Name (P) then
8510                   null;
8511
8512                elsif Is_Overloadable (Entity (P))
8513                  and then Is_Abstract_Subprogram (Entity (P))
8514                then
8515                   Error_Msg_F ("prefix of % attribute cannot be abstract", P);
8516                   Set_Etype (N, Any_Type);
8517
8518                elsif Convention (Entity (P)) = Convention_Intrinsic then
8519                   if Ekind (Entity (P)) = E_Enumeration_Literal then
8520                      Error_Msg_F
8521                        ("prefix of % attribute cannot be enumeration literal",
8522                         P);
8523                   else
8524                      Error_Msg_F
8525                        ("prefix of % attribute cannot be intrinsic", P);
8526                   end if;
8527
8528                   Set_Etype (N, Any_Type);
8529                end if;
8530
8531                --  Assignments, return statements, components of aggregates,
8532                --  generic instantiations will require convention checks if
8533                --  the type is an access to subprogram. Given that there will
8534                --  also be accessibility checks on those, this is where the
8535                --  checks can eventually be centralized ???
8536
8537                if Ekind_In (Btyp, E_Access_Subprogram_Type,
8538                                   E_Anonymous_Access_Subprogram_Type,
8539                                   E_Access_Protected_Subprogram_Type,
8540                                   E_Anonymous_Access_Protected_Subprogram_Type)
8541                then
8542                   --  Deal with convention mismatch
8543
8544                   if Convention (Designated_Type (Btyp)) /=
8545                      Convention (Entity (P))
8546                   then
8547                      Error_Msg_FE
8548                        ("subprogram & has wrong convention", P, Entity (P));
8549                      Error_Msg_FE
8550                        ("\does not match convention of access type &",
8551                         P, Btyp);
8552
8553                      if not Has_Convention_Pragma (Btyp) then
8554                         Error_Msg_FE
8555                           ("\probable missing pragma Convention for &",
8556                            P, Btyp);
8557                      end if;
8558
8559                   else
8560                      Check_Subtype_Conformant
8561                        (New_Id  => Entity (P),
8562                         Old_Id  => Designated_Type (Btyp),
8563                         Err_Loc => P);
8564                   end if;
8565
8566                   if Attr_Id = Attribute_Unchecked_Access then
8567                      Error_Msg_Name_1 := Aname;
8568                      Error_Msg_F
8569                        ("attribute% cannot be applied to a subprogram", P);
8570
8571                   elsif Aname = Name_Unrestricted_Access then
8572                      null;  --  Nothing to check
8573
8574                   --  Check the static accessibility rule of 3.10.2(32).
8575                   --  This rule also applies within the private part of an
8576                   --  instantiation. This rule does not apply to anonymous
8577                   --  access-to-subprogram types in access parameters.
8578
8579                   elsif Attr_Id = Attribute_Access
8580                     and then not In_Instance_Body
8581                     and then
8582                       (Ekind (Btyp) = E_Access_Subprogram_Type
8583                         or else Is_Local_Anonymous_Access (Btyp))
8584
8585                     and then Subprogram_Access_Level (Entity (P)) >
8586                                Type_Access_Level (Btyp)
8587                   then
8588                      Error_Msg_F
8589                        ("subprogram must not be deeper than access type", P);
8590
8591                   --  Check the restriction of 3.10.2(32) that disallows the
8592                   --  access attribute within a generic body when the ultimate
8593                   --  ancestor of the type of the attribute is declared outside
8594                   --  of the generic unit and the subprogram is declared within
8595                   --  that generic unit. This includes any such attribute that
8596                   --  occurs within the body of a generic unit that is a child
8597                   --  of the generic unit where the subprogram is declared.
8598
8599                   --  The rule also prohibits applying the attribute when the
8600                   --  access type is a generic formal access type (since the
8601                   --  level of the actual type is not known). This restriction
8602                   --  does not apply when the attribute type is an anonymous
8603                   --  access-to-subprogram type. Note that this check was
8604                   --  revised by AI-229, because the originally Ada 95 rule
8605                   --  was too lax. The original rule only applied when the
8606                   --  subprogram was declared within the body of the generic,
8607                   --  which allowed the possibility of dangling references).
8608                   --  The rule was also too strict in some case, in that it
8609                   --  didn't permit the access to be declared in the generic
8610                   --  spec, whereas the revised rule does (as long as it's not
8611                   --  a formal type).
8612
8613                   --  There are a couple of subtleties of the test for applying
8614                   --  the check that are worth noting. First, we only apply it
8615                   --  when the levels of the subprogram and access type are the
8616                   --  same (the case where the subprogram is statically deeper
8617                   --  was applied above, and the case where the type is deeper
8618                   --  is always safe). Second, we want the check to apply
8619                   --  within nested generic bodies and generic child unit
8620                   --  bodies, but not to apply to an attribute that appears in
8621                   --  the generic unit's specification. This is done by testing
8622                   --  that the attribute's innermost enclosing generic body is
8623                   --  not the same as the innermost generic body enclosing the
8624                   --  generic unit where the subprogram is declared (we don't
8625                   --  want the check to apply when the access attribute is in
8626                   --  the spec and there's some other generic body enclosing
8627                   --  generic). Finally, there's no point applying the check
8628                   --  when within an instance, because any violations will have
8629                   --  been caught by the compilation of the generic unit.
8630
8631                   --  Note that we relax this check in CodePeer mode for
8632                   --  compatibility with legacy code, since CodePeer is an
8633                   --  Ada source code analyzer, not a strict compiler.
8634                   --  ??? Note that a better approach would be to have a
8635                   --  separate switch to relax this rule, and enable this
8636                   --  switch in CodePeer mode.
8637
8638                   elsif Attr_Id = Attribute_Access
8639                     and then not CodePeer_Mode
8640                     and then not In_Instance
8641                     and then Present (Enclosing_Generic_Unit (Entity (P)))
8642                     and then Present (Enclosing_Generic_Body (N))
8643                     and then Enclosing_Generic_Body (N) /=
8644                                Enclosing_Generic_Body
8645                                  (Enclosing_Generic_Unit (Entity (P)))
8646                     and then Subprogram_Access_Level (Entity (P)) =
8647                                Type_Access_Level (Btyp)
8648                     and then Ekind (Btyp) /=
8649                                E_Anonymous_Access_Subprogram_Type
8650                     and then Ekind (Btyp) /=
8651                                E_Anonymous_Access_Protected_Subprogram_Type
8652                   then
8653                      --  The attribute type's ultimate ancestor must be
8654                      --  declared within the same generic unit as the
8655                      --  subprogram is declared. The error message is
8656                      --  specialized to say "ancestor" for the case where the
8657                      --  access type is not its own ancestor, since saying
8658                      --  simply "access type" would be very confusing.
8659
8660                      if Enclosing_Generic_Unit (Entity (P)) /=
8661                           Enclosing_Generic_Unit (Root_Type (Btyp))
8662                      then
8663                         Error_Msg_N
8664                           ("''Access attribute not allowed in generic body",
8665                            N);
8666
8667                         if Root_Type (Btyp) = Btyp then
8668                            Error_Msg_NE
8669                              ("\because " &
8670                               "access type & is declared outside " &
8671                               "generic unit (RM 3.10.2(32))", N, Btyp);
8672                         else
8673                            Error_Msg_NE
8674                              ("\because ancestor of " &
8675                               "access type & is declared outside " &
8676                               "generic unit (RM 3.10.2(32))", N, Btyp);
8677                         end if;
8678
8679                         Error_Msg_NE
8680                           ("\move ''Access to private part, or " &
8681                            "(Ada 2005) use anonymous access type instead of &",
8682                            N, Btyp);
8683
8684                      --  If the ultimate ancestor of the attribute's type is
8685                      --  a formal type, then the attribute is illegal because
8686                      --  the actual type might be declared at a higher level.
8687                      --  The error message is specialized to say "ancestor"
8688                      --  for the case where the access type is not its own
8689                      --  ancestor, since saying simply "access type" would be
8690                      --  very confusing.
8691
8692                      elsif Is_Generic_Type (Root_Type (Btyp)) then
8693                         if Root_Type (Btyp) = Btyp then
8694                            Error_Msg_N
8695                              ("access type must not be a generic formal type",
8696                               N);
8697                         else
8698                            Error_Msg_N
8699                              ("ancestor access type must not be a generic " &
8700                               "formal type", N);
8701                         end if;
8702                      end if;
8703                   end if;
8704                end if;
8705
8706                --  If this is a renaming, an inherited operation, or a
8707                --  subprogram instance, use the original entity. This may make
8708                --  the node type-inconsistent, so this transformation can only
8709                --  be done if the node will not be reanalyzed. In particular,
8710                --  if it is within a default expression, the transformation
8711                --  must be delayed until the default subprogram is created for
8712                --  it, when the enclosing subprogram is frozen.
8713
8714                if Is_Entity_Name (P)
8715                  and then Is_Overloadable (Entity (P))
8716                  and then Present (Alias (Entity (P)))
8717                  and then Expander_Active
8718                then
8719                   Rewrite (P,
8720                     New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
8721                end if;
8722
8723             elsif Nkind (P) = N_Selected_Component
8724               and then Is_Overloadable (Entity (Selector_Name (P)))
8725             then
8726                --  Protected operation. If operation is overloaded, must
8727                --  disambiguate. Prefix that denotes protected object itself
8728                --  is resolved with its own type.
8729
8730                if Attr_Id = Attribute_Unchecked_Access then
8731                   Error_Msg_Name_1 := Aname;
8732                   Error_Msg_F
8733                     ("attribute% cannot be applied to protected operation", P);
8734                end if;
8735
8736                Resolve (Prefix (P));
8737                Generate_Reference (Entity (Selector_Name (P)), P);
8738
8739             elsif Is_Overloaded (P) then
8740
8741                --  Use the designated type of the context to disambiguate
8742                --  Note that this was not strictly conformant to Ada 95,
8743                --  but was the implementation adopted by most Ada 95 compilers.
8744                --  The use of the context type to resolve an Access attribute
8745                --  reference is now mandated in AI-235 for Ada 2005.
8746
8747                declare
8748                   Index : Interp_Index;
8749                   It    : Interp;
8750
8751                begin
8752                   Get_First_Interp (P, Index, It);
8753                   while Present (It.Typ) loop
8754                      if Covers (Designated_Type (Typ), It.Typ) then
8755                         Resolve (P, It.Typ);
8756                         exit;
8757                      end if;
8758
8759                      Get_Next_Interp (Index, It);
8760                   end loop;
8761                end;
8762             else
8763                Resolve (P);
8764             end if;
8765
8766             --  X'Access is illegal if X denotes a constant and the access type
8767             --  is access-to-variable. Same for 'Unchecked_Access. The rule
8768             --  does not apply to 'Unrestricted_Access. If the reference is a
8769             --  default-initialized aggregate component for a self-referential
8770             --  type the reference is legal.
8771
8772             if not (Ekind (Btyp) = E_Access_Subprogram_Type
8773                      or else Ekind (Btyp) = E_Anonymous_Access_Subprogram_Type
8774                      or else (Is_Record_Type (Btyp)
8775                                and then
8776                                  Present (Corresponding_Remote_Type (Btyp)))
8777                      or else Ekind (Btyp) = E_Access_Protected_Subprogram_Type
8778                      or else Ekind (Btyp)
8779                                = E_Anonymous_Access_Protected_Subprogram_Type
8780                      or else Is_Access_Constant (Btyp)
8781                      or else Is_Variable (P)
8782                      or else Attr_Id = Attribute_Unrestricted_Access)
8783             then
8784                if Is_Entity_Name (P)
8785                  and then Is_Type (Entity (P))
8786                then
8787                   --  Legality of a self-reference through an access
8788                   --  attribute has been verified in Analyze_Access_Attribute.
8789
8790                   null;
8791
8792                elsif Comes_From_Source (N) then
8793                   Error_Msg_F ("access-to-variable designates constant", P);
8794                end if;
8795             end if;
8796
8797             Des_Btyp := Designated_Type (Btyp);
8798
8799             if Ada_Version >= Ada_2005
8800               and then Is_Incomplete_Type (Des_Btyp)
8801             then
8802                --  Ada 2005 (AI-412): If the (sub)type is a limited view of an
8803                --  imported entity, and the non-limited view is visible, make
8804                --  use of it. If it is an incomplete subtype, use the base type
8805                --  in any case.
8806
8807                if From_With_Type (Des_Btyp)
8808                  and then Present (Non_Limited_View (Des_Btyp))
8809                then
8810                   Des_Btyp := Non_Limited_View (Des_Btyp);
8811
8812                elsif Ekind (Des_Btyp) = E_Incomplete_Subtype then
8813                   Des_Btyp := Etype (Des_Btyp);
8814                end if;
8815             end if;
8816
8817             if (Attr_Id = Attribute_Access
8818                   or else
8819                 Attr_Id = Attribute_Unchecked_Access)
8820               and then (Ekind (Btyp) = E_General_Access_Type
8821                           or else Ekind (Btyp) = E_Anonymous_Access_Type)
8822             then
8823                --  Ada 2005 (AI-230): Check the accessibility of anonymous
8824                --  access types for stand-alone objects, record and array
8825                --  components, and return objects. For a component definition
8826                --  the level is the same of the enclosing composite type.
8827
8828                if Ada_Version >= Ada_2005
8829                  and then (Is_Local_Anonymous_Access (Btyp)
8830
8831                             --  Handle cases where Btyp is the anonymous access
8832                             --  type of an Ada 2012 stand-alone object.
8833
8834                             or else Nkind (Associated_Node_For_Itype (Btyp)) =
8835                                                         N_Object_Declaration)
8836                  and then
8837                    Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp)
8838                  and then Attr_Id = Attribute_Access
8839                then
8840                   --  In an instance, this is a runtime check, but one we
8841                   --  know will fail, so generate an appropriate warning.
8842
8843                   if In_Instance_Body then
8844                      Error_Msg_F
8845                        ("?non-local pointer cannot point to local object", P);
8846                      Error_Msg_F
8847                        ("\?Program_Error will be raised at run time", P);
8848                      Rewrite (N,
8849                        Make_Raise_Program_Error (Loc,
8850                          Reason => PE_Accessibility_Check_Failed));
8851                      Set_Etype (N, Typ);
8852
8853                   else
8854                      Error_Msg_F
8855                        ("non-local pointer cannot point to local object", P);
8856                   end if;
8857                end if;
8858
8859                if Is_Dependent_Component_Of_Mutable_Object (P) then
8860                   Error_Msg_F
8861                     ("illegal attribute for discriminant-dependent component",
8862                      P);
8863                end if;
8864
8865                --  Check static matching rule of 3.10.2(27). Nominal subtype
8866                --  of the prefix must statically match the designated type.
8867
8868                Nom_Subt := Etype (P);
8869
8870                if Is_Constr_Subt_For_U_Nominal (Nom_Subt) then
8871                   Nom_Subt := Base_Type (Nom_Subt);
8872                end if;
8873
8874                if Is_Tagged_Type (Designated_Type (Typ)) then
8875
8876                   --  If the attribute is in the context of an access
8877                   --  parameter, then the prefix is allowed to be of the
8878                   --  class-wide type (by AI-127).
8879
8880                   if Ekind (Typ) = E_Anonymous_Access_Type then
8881                      if not Covers (Designated_Type (Typ), Nom_Subt)
8882                        and then not Covers (Nom_Subt, Designated_Type (Typ))
8883                      then
8884                         declare
8885                            Desig : Entity_Id;
8886
8887                         begin
8888                            Desig := Designated_Type (Typ);
8889
8890                            if Is_Class_Wide_Type (Desig) then
8891                               Desig := Etype (Desig);
8892                            end if;
8893
8894                            if Is_Anonymous_Tagged_Base (Nom_Subt, Desig) then
8895                               null;
8896
8897                            else
8898                               Error_Msg_FE
8899                                 ("type of prefix: & not compatible",
8900                                   P, Nom_Subt);
8901                               Error_Msg_FE
8902                                 ("\with &, the expected designated type",
8903                                   P, Designated_Type (Typ));
8904                            end if;
8905                         end;
8906                      end if;
8907
8908                   elsif not Covers (Designated_Type (Typ), Nom_Subt)
8909                     or else
8910                       (not Is_Class_Wide_Type (Designated_Type (Typ))
8911                         and then Is_Class_Wide_Type (Nom_Subt))
8912                   then
8913                      Error_Msg_FE
8914                        ("type of prefix: & is not covered", P, Nom_Subt);
8915                      Error_Msg_FE
8916                        ("\by &, the expected designated type" &
8917                            " (RM 3.10.2 (27))", P, Designated_Type (Typ));
8918                   end if;
8919
8920                   if Is_Class_Wide_Type (Designated_Type (Typ))
8921                     and then Has_Discriminants (Etype (Designated_Type (Typ)))
8922                     and then Is_Constrained (Etype (Designated_Type (Typ)))
8923                     and then Designated_Type (Typ) /= Nom_Subt
8924                   then
8925                      Apply_Discriminant_Check
8926                        (N, Etype (Designated_Type (Typ)));
8927                   end if;
8928
8929                --  Ada 2005 (AI-363): Require static matching when designated
8930                --  type has discriminants and a constrained partial view, since
8931                --  in general objects of such types are mutable, so we can't
8932                --  allow the access value to designate a constrained object
8933                --  (because access values must be assumed to designate mutable
8934                --  objects when designated type does not impose a constraint).
8935
8936                elsif Subtypes_Statically_Match (Des_Btyp, Nom_Subt) then
8937                   null;
8938
8939                elsif Has_Discriminants (Designated_Type (Typ))
8940                  and then not Is_Constrained (Des_Btyp)
8941                  and then
8942                    (Ada_Version < Ada_2005
8943                      or else
8944                        not Effectively_Has_Constrained_Partial_View
8945                              (Typ => Designated_Type (Base_Type (Typ)),
8946                               Scop => Current_Scope))
8947                then
8948                   null;
8949
8950                else
8951                   Error_Msg_F
8952                     ("object subtype must statically match "
8953                      & "designated subtype", P);
8954
8955                   if Is_Entity_Name (P)
8956                     and then Is_Array_Type (Designated_Type (Typ))
8957                   then
8958                      declare
8959                         D : constant Node_Id := Declaration_Node (Entity (P));
8960                      begin
8961                         Error_Msg_N ("aliased object has explicit bounds?",
8962                           D);
8963                         Error_Msg_N ("\declare without bounds"
8964                           & " (and with explicit initialization)?", D);
8965                         Error_Msg_N ("\for use with unconstrained access?", D);
8966                      end;
8967                   end if;
8968                end if;
8969
8970                --  Check the static accessibility rule of 3.10.2(28). Note that
8971                --  this check is not performed for the case of an anonymous
8972                --  access type, since the access attribute is always legal
8973                --  in such a context.
8974
8975                if Attr_Id /= Attribute_Unchecked_Access
8976                  and then
8977                    Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp)
8978                  and then Ekind (Btyp) = E_General_Access_Type
8979                then
8980                   Accessibility_Message;
8981                   return;
8982                end if;
8983             end if;
8984
8985             if Ekind_In (Btyp, E_Access_Protected_Subprogram_Type,
8986                                E_Anonymous_Access_Protected_Subprogram_Type)
8987             then
8988                if Is_Entity_Name (P)
8989                  and then not Is_Protected_Type (Scope (Entity (P)))
8990                then
8991                   Error_Msg_F ("context requires a protected subprogram", P);
8992
8993                --  Check accessibility of protected object against that of the
8994                --  access type, but only on user code, because the expander
8995                --  creates access references for handlers. If the context is an
8996                --  anonymous_access_to_protected, there are no accessibility
8997                --  checks either. Omit check entirely for Unrestricted_Access.
8998
8999                elsif Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp)
9000                  and then Comes_From_Source (N)
9001                  and then Ekind (Btyp) = E_Access_Protected_Subprogram_Type
9002                  and then Attr_Id /= Attribute_Unrestricted_Access
9003                then
9004                   Accessibility_Message;
9005                   return;
9006                end if;
9007
9008             elsif Ekind_In (Btyp, E_Access_Subprogram_Type,
9009                                   E_Anonymous_Access_Subprogram_Type)
9010               and then Ekind (Etype (N)) = E_Access_Protected_Subprogram_Type
9011             then
9012                Error_Msg_F ("context requires a non-protected subprogram", P);
9013             end if;
9014
9015             --  The context cannot be a pool-specific type, but this is a
9016             --  legality rule, not a resolution rule, so it must be checked
9017             --  separately, after possibly disambiguation (see AI-245).
9018
9019             if Ekind (Btyp) = E_Access_Type
9020               and then Attr_Id /= Attribute_Unrestricted_Access
9021             then
9022                Wrong_Type (N, Typ);
9023             end if;
9024
9025             --  The context may be a constrained access type (however ill-
9026             --  advised such subtypes might be) so in order to generate a
9027             --  constraint check when needed set the type of the attribute
9028             --  reference to the base type of the context.
9029
9030             Set_Etype (N, Btyp);
9031
9032             --  Check for incorrect atomic/volatile reference (RM C.6(12))
9033
9034             if Attr_Id /= Attribute_Unrestricted_Access then
9035                if Is_Atomic_Object (P)
9036                  and then not Is_Atomic (Designated_Type (Typ))
9037                then
9038                   Error_Msg_F
9039                     ("access to atomic object cannot yield access-to-" &
9040                      "non-atomic type", P);
9041
9042                elsif Is_Volatile_Object (P)
9043                  and then not Is_Volatile (Designated_Type (Typ))
9044                then
9045                   Error_Msg_F
9046                     ("access to volatile object cannot yield access-to-" &
9047                      "non-volatile type", P);
9048                end if;
9049             end if;
9050
9051             if Is_Entity_Name (P) then
9052                Set_Address_Taken (Entity (P));
9053             end if;
9054          end Access_Attribute;
9055
9056          -------------
9057          -- Address --
9058          -------------
9059
9060          --  Deal with resolving the type for Address attribute, overloading
9061          --  is not permitted here, since there is no context to resolve it.
9062
9063          when Attribute_Address | Attribute_Code_Address =>
9064          Address_Attribute : begin
9065
9066             --  To be safe, assume that if the address of a variable is taken,
9067             --  it may be modified via this address, so note modification.
9068
9069             if Is_Variable (P) then
9070                Note_Possible_Modification (P, Sure => False);
9071             end if;
9072
9073             if Nkind (P) in N_Subexpr
9074               and then Is_Overloaded (P)
9075             then
9076                Get_First_Interp (P, Index, It);
9077                Get_Next_Interp (Index, It);
9078
9079                if Present (It.Nam) then
9080                   Error_Msg_Name_1 := Aname;
9081                   Error_Msg_F
9082                     ("prefix of % attribute cannot be overloaded", P);
9083                end if;
9084             end if;
9085
9086             if not Is_Entity_Name (P)
9087               or else not Is_Overloadable (Entity (P))
9088             then
9089                if not Is_Task_Type (Etype (P))
9090                  or else Nkind (P) = N_Explicit_Dereference
9091                then
9092                   Resolve (P);
9093                end if;
9094             end if;
9095
9096             --  If this is the name of a derived subprogram, or that of a
9097             --  generic actual, the address is that of the original entity.
9098
9099             if Is_Entity_Name (P)
9100               and then Is_Overloadable (Entity (P))
9101               and then Present (Alias (Entity (P)))
9102             then
9103                Rewrite (P,
9104                  New_Occurrence_Of (Alias (Entity (P)), Sloc (P)));
9105             end if;
9106
9107             if Is_Entity_Name (P) then
9108                Set_Address_Taken (Entity (P));
9109             end if;
9110
9111             if Nkind (P) = N_Slice then
9112
9113                --  Arr (X .. Y)'address is identical to Arr (X)'address,
9114                --  even if the array is packed and the slice itself is not
9115                --  addressable. Transform the prefix into an indexed component.
9116
9117                --  Note that the transformation is safe only if we know that
9118                --  the slice is non-null. That is because a null slice can have
9119                --  an out of bounds index value.
9120
9121                --  Right now, gigi blows up if given 'Address on a slice as a
9122                --  result of some incorrect freeze nodes generated by the front
9123                --  end, and this covers up that bug in one case, but the bug is
9124                --  likely still there in the cases not handled by this code ???
9125
9126                --  It's not clear what 'Address *should* return for a null
9127                --  slice with out of bounds indexes, this might be worth an ARG
9128                --  discussion ???
9129
9130                --  One approach would be to do a length check unconditionally,
9131                --  and then do the transformation below unconditionally, but
9132                --  analyze with checks off, avoiding the problem of the out of
9133                --  bounds index. This approach would interpret the address of
9134                --  an out of bounds null slice as being the address where the
9135                --  array element would be if there was one, which is probably
9136                --  as reasonable an interpretation as any ???
9137
9138                declare
9139                   Loc : constant Source_Ptr := Sloc (P);
9140                   D   : constant Node_Id := Discrete_Range (P);
9141                   Lo  : Node_Id;
9142
9143                begin
9144                   if Is_Entity_Name (D)
9145                     and then
9146                       Not_Null_Range
9147                         (Type_Low_Bound (Entity (D)),
9148                          Type_High_Bound (Entity (D)))
9149                   then
9150                      Lo :=
9151                        Make_Attribute_Reference (Loc,
9152                           Prefix => (New_Occurrence_Of (Entity (D), Loc)),
9153                           Attribute_Name => Name_First);
9154
9155                   elsif Nkind (D) = N_Range
9156                     and then Not_Null_Range (Low_Bound (D), High_Bound (D))
9157                   then
9158                      Lo := Low_Bound (D);
9159
9160                   else
9161                      Lo := Empty;
9162                   end if;
9163
9164                   if Present (Lo) then
9165                      Rewrite (P,
9166                         Make_Indexed_Component (Loc,
9167                            Prefix =>  Relocate_Node (Prefix (P)),
9168                            Expressions => New_List (Lo)));
9169
9170                      Analyze_And_Resolve (P);
9171                   end if;
9172                end;
9173             end if;
9174          end Address_Attribute;
9175
9176          ---------------
9177          -- AST_Entry --
9178          ---------------
9179
9180          --  Prefix of the AST_Entry attribute is an entry name which must
9181          --  not be resolved, since this is definitely not an entry call.
9182
9183          when Attribute_AST_Entry =>
9184             null;
9185
9186          ------------------
9187          -- Body_Version --
9188          ------------------
9189
9190          --  Prefix of Body_Version attribute can be a subprogram name which
9191          --  must not be resolved, since this is not a call.
9192
9193          when Attribute_Body_Version =>
9194             null;
9195
9196          ------------
9197          -- Caller --
9198          ------------
9199
9200          --  Prefix of Caller attribute is an entry name which must not
9201          --  be resolved, since this is definitely not an entry call.
9202
9203          when Attribute_Caller =>
9204             null;
9205
9206          ------------------
9207          -- Code_Address --
9208          ------------------
9209
9210          --  Shares processing with Address attribute
9211
9212          -----------
9213          -- Count --
9214          -----------
9215
9216          --  If the prefix of the Count attribute is an entry name it must not
9217          --  be resolved, since this is definitely not an entry call. However,
9218          --  if it is an element of an entry family, the index itself may
9219          --  have to be resolved because it can be a general expression.
9220
9221          when Attribute_Count =>
9222             if Nkind (P) = N_Indexed_Component
9223               and then Is_Entity_Name (Prefix (P))
9224             then
9225                declare
9226                   Indx : constant Node_Id   := First (Expressions (P));
9227                   Fam  : constant Entity_Id := Entity (Prefix (P));
9228                begin
9229                   Resolve (Indx, Entry_Index_Type (Fam));
9230                   Apply_Range_Check (Indx, Entry_Index_Type (Fam));
9231                end;
9232             end if;
9233
9234          ----------------
9235          -- Elaborated --
9236          ----------------
9237
9238          --  Prefix of the Elaborated attribute is a subprogram name which
9239          --  must not be resolved, since this is definitely not a call. Note
9240          --  that it is a library unit, so it cannot be overloaded here.
9241
9242          when Attribute_Elaborated =>
9243             null;
9244
9245          -------------
9246          -- Enabled --
9247          -------------
9248
9249          --  Prefix of Enabled attribute is a check name, which must be treated
9250          --  specially and not touched by Resolve.
9251
9252          when Attribute_Enabled =>
9253             null;
9254
9255          --------------------
9256          -- Mechanism_Code --
9257          --------------------
9258
9259          --  Prefix of the Mechanism_Code attribute is a function name
9260          --  which must not be resolved. Should we check for overloaded ???
9261
9262          when Attribute_Mechanism_Code =>
9263             null;
9264
9265          ------------------
9266          -- Partition_ID --
9267          ------------------
9268
9269          --  Most processing is done in sem_dist, after determining the
9270          --  context type. Node is rewritten as a conversion to a runtime call.
9271
9272          when Attribute_Partition_ID =>
9273             Process_Partition_Id (N);
9274             return;
9275
9276          ------------------
9277          -- Pool_Address --
9278          ------------------
9279
9280          when Attribute_Pool_Address =>
9281             Resolve (P);
9282
9283          -----------
9284          -- Range --
9285          -----------
9286
9287          --  We replace the Range attribute node with a range expression whose
9288          --  bounds are the 'First and 'Last attributes applied to the same
9289          --  prefix. The reason that we do this transformation here instead of
9290          --  in the expander is that it simplifies other parts of the semantic
9291          --  analysis which assume that the Range has been replaced; thus it
9292          --  must be done even when in semantic-only mode (note that the RM
9293          --  specifically mentions this equivalence, we take care that the
9294          --  prefix is only evaluated once).
9295
9296          when Attribute_Range => Range_Attribute :
9297             declare
9298                LB   : Node_Id;
9299                HB   : Node_Id;
9300                Dims : List_Id;
9301
9302             begin
9303                if not Is_Entity_Name (P)
9304                  or else not Is_Type (Entity (P))
9305                then
9306                   Resolve (P);
9307                end if;
9308
9309                Dims := Expressions (N);
9310
9311                HB :=
9312                  Make_Attribute_Reference (Loc,
9313                    Prefix         =>
9314                      Duplicate_Subexpr (P, Name_Req => True),
9315                    Attribute_Name => Name_Last,
9316                    Expressions    => Dims);
9317
9318                LB :=
9319                  Make_Attribute_Reference (Loc,
9320                    Prefix          => P,
9321                    Attribute_Name  => Name_First,
9322                    Expressions     => (Dims));
9323
9324                --  Do not share the dimension indicator, if present. Even
9325                --  though it is a static constant, its source location
9326                --  may be modified when printing expanded code and node
9327                --  sharing will lead to chaos in Sprint.
9328
9329                if Present (Dims) then
9330                   Set_Expressions (LB,
9331                     New_List (New_Copy_Tree (First (Dims))));
9332                end if;
9333
9334                --  If the original was marked as Must_Not_Freeze (see code
9335                --  in Sem_Ch3.Make_Index), then make sure the rewriting
9336                --  does not freeze either.
9337
9338                if Must_Not_Freeze (N) then
9339                   Set_Must_Not_Freeze (HB);
9340                   Set_Must_Not_Freeze (LB);
9341                   Set_Must_Not_Freeze (Prefix (HB));
9342                   Set_Must_Not_Freeze (Prefix (LB));
9343                end if;
9344
9345                if Raises_Constraint_Error (Prefix (N)) then
9346
9347                   --  Preserve Sloc of prefix in the new bounds, so that
9348                   --  the posted warning can be removed if we are within
9349                   --  unreachable code.
9350
9351                   Set_Sloc (LB, Sloc (Prefix (N)));
9352                   Set_Sloc (HB, Sloc (Prefix (N)));
9353                end if;
9354
9355                Rewrite (N, Make_Range (Loc, LB, HB));
9356                Analyze_And_Resolve (N, Typ);
9357
9358                --  Ensure that the expanded range does not have side effects
9359
9360                Force_Evaluation (LB);
9361                Force_Evaluation (HB);
9362
9363                --  Normally after resolving attribute nodes, Eval_Attribute
9364                --  is called to do any possible static evaluation of the node.
9365                --  However, here since the Range attribute has just been
9366                --  transformed into a range expression it is no longer an
9367                --  attribute node and therefore the call needs to be avoided
9368                --  and is accomplished by simply returning from the procedure.
9369
9370                return;
9371             end Range_Attribute;
9372
9373          ------------
9374          -- Result --
9375          ------------
9376
9377          --  We will only come here during the prescan of a spec expression
9378          --  containing a Result attribute. In that case the proper Etype has
9379          --  already been set, and nothing more needs to be done here.
9380
9381          when Attribute_Result =>
9382             null;
9383
9384          -----------------
9385          -- UET_Address --
9386          -----------------
9387
9388          --  Prefix must not be resolved in this case, since it is not a
9389          --  real entity reference. No action of any kind is require!
9390
9391          when Attribute_UET_Address =>
9392             return;
9393
9394          ----------------------
9395          -- Unchecked_Access --
9396          ----------------------
9397
9398          --  Processing is shared with Access
9399
9400          -------------------------
9401          -- Unrestricted_Access --
9402          -------------------------
9403
9404          --  Processing is shared with Access
9405
9406          ---------
9407          -- Val --
9408          ---------
9409
9410          --  Apply range check. Note that we did not do this during the
9411          --  analysis phase, since we wanted Eval_Attribute to have a
9412          --  chance at finding an illegal out of range value.
9413
9414          when Attribute_Val =>
9415
9416             --  Note that we do our own Eval_Attribute call here rather than
9417             --  use the common one, because we need to do processing after
9418             --  the call, as per above comment.
9419
9420             Eval_Attribute (N);
9421
9422             --  Eval_Attribute may replace the node with a raise CE, or
9423             --  fold it to a constant. Obviously we only apply a scalar
9424             --  range check if this did not happen!
9425
9426             if Nkind (N) = N_Attribute_Reference
9427               and then Attribute_Name (N) = Name_Val
9428             then
9429                Apply_Scalar_Range_Check (First (Expressions (N)), Btyp);
9430             end if;
9431
9432             return;
9433
9434          -------------
9435          -- Version --
9436          -------------
9437
9438          --  Prefix of Version attribute can be a subprogram name which
9439          --  must not be resolved, since this is not a call.
9440
9441          when Attribute_Version =>
9442             null;
9443
9444          ----------------------
9445          -- Other Attributes --
9446          ----------------------
9447
9448          --  For other attributes, resolve prefix unless it is a type. If
9449          --  the attribute reference itself is a type name ('Base and 'Class)
9450          --  then this is only legal within a task or protected record.
9451
9452          when others =>
9453             if not Is_Entity_Name (P)
9454               or else not Is_Type (Entity (P))
9455             then
9456                Resolve (P);
9457             end if;
9458
9459             --  If the attribute reference itself is a type name ('Base,
9460             --  'Class) then this is only legal within a task or protected
9461             --  record. What is this all about ???
9462
9463             if Is_Entity_Name (N)
9464               and then Is_Type (Entity (N))
9465             then
9466                if Is_Concurrent_Type (Entity (N))
9467                  and then In_Open_Scopes (Entity (P))
9468                then
9469                   null;
9470                else
9471                   Error_Msg_N
9472                     ("invalid use of subtype name in expression or call", N);
9473                end if;
9474             end if;
9475
9476             --  For attributes whose argument may be a string, complete
9477             --  resolution of argument now. This avoids premature expansion
9478             --  (and the creation of transient scopes) before the attribute
9479             --  reference is resolved.
9480
9481             case Attr_Id is
9482                when Attribute_Value =>
9483                   Resolve (First (Expressions (N)), Standard_String);
9484
9485                when Attribute_Wide_Value =>
9486                   Resolve (First (Expressions (N)), Standard_Wide_String);
9487
9488                when Attribute_Wide_Wide_Value =>
9489                   Resolve (First (Expressions (N)), Standard_Wide_Wide_String);
9490
9491                when others => null;
9492             end case;
9493
9494             --  If the prefix of the attribute is a class-wide type then it
9495             --  will be expanded into a dispatching call to a predefined
9496             --  primitive. Therefore we must check for potential violation
9497             --  of such restriction.
9498
9499             if Is_Class_Wide_Type (Etype (P)) then
9500                Check_Restriction (No_Dispatching_Calls, N);
9501             end if;
9502       end case;
9503
9504       --  Normally the Freezing is done by Resolve but sometimes the Prefix
9505       --  is not resolved, in which case the freezing must be done now.
9506
9507       Freeze_Expression (P);
9508
9509       --  Finally perform static evaluation on the attribute reference
9510
9511       Analyze_Dimension (N);
9512       Eval_Attribute (N);
9513    end Resolve_Attribute;
9514
9515    --------------------------------
9516    -- Stream_Attribute_Available --
9517    --------------------------------
9518
9519    function Stream_Attribute_Available
9520      (Typ          : Entity_Id;
9521       Nam          : TSS_Name_Type;
9522       Partial_View : Node_Id := Empty) return Boolean
9523    is
9524       Etyp : Entity_Id := Typ;
9525
9526    --  Start of processing for Stream_Attribute_Available
9527
9528    begin
9529       --  We need some comments in this body ???
9530
9531       if Has_Stream_Attribute_Definition (Typ, Nam) then
9532          return True;
9533       end if;
9534
9535       if Is_Class_Wide_Type (Typ) then
9536          return not Is_Limited_Type (Typ)
9537            or else Stream_Attribute_Available (Etype (Typ), Nam);
9538       end if;
9539
9540       if Nam = TSS_Stream_Input
9541         and then Is_Abstract_Type (Typ)
9542         and then not Is_Class_Wide_Type (Typ)
9543       then
9544          return False;
9545       end if;
9546
9547       if not (Is_Limited_Type (Typ)
9548         or else (Present (Partial_View)
9549                    and then Is_Limited_Type (Partial_View)))
9550       then
9551          return True;
9552       end if;
9553
9554       --  In Ada 2005, Input can invoke Read, and Output can invoke Write
9555
9556       if Nam = TSS_Stream_Input
9557         and then Ada_Version >= Ada_2005
9558         and then Stream_Attribute_Available (Etyp, TSS_Stream_Read)
9559       then
9560          return True;
9561
9562       elsif Nam = TSS_Stream_Output
9563         and then Ada_Version >= Ada_2005
9564         and then Stream_Attribute_Available (Etyp, TSS_Stream_Write)
9565       then
9566          return True;
9567       end if;
9568
9569       --  Case of Read and Write: check for attribute definition clause that
9570       --  applies to an ancestor type.
9571
9572       while Etype (Etyp) /= Etyp loop
9573          Etyp := Etype (Etyp);
9574
9575          if Has_Stream_Attribute_Definition (Etyp, Nam) then
9576             return True;
9577          end if;
9578       end loop;
9579
9580       if Ada_Version < Ada_2005 then
9581
9582          --  In Ada 95 mode, also consider a non-visible definition
9583
9584          declare
9585             Btyp : constant Entity_Id := Implementation_Base_Type (Typ);
9586          begin
9587             return Btyp /= Typ
9588               and then Stream_Attribute_Available
9589                          (Btyp, Nam, Partial_View => Typ);
9590          end;
9591       end if;
9592
9593       return False;
9594    end Stream_Attribute_Available;
9595
9596 end Sem_Attr;