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