gcc/ada/sem_attr.adb

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