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