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