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