gcc/ada/exp_attr.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ A T T R                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2011, 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 Atree;    use Atree;
  27 with Checks;   use Checks;
  28 with Einfo;    use Einfo;
  29 with Elists;   use Elists;
  30 with Exp_Atag; use Exp_Atag;
  31 with Exp_Ch2;  use Exp_Ch2;
  32 with Exp_Ch3;  use Exp_Ch3;
  33 with Exp_Ch6;  use Exp_Ch6;
  34 with Exp_Ch9;  use Exp_Ch9;
  35 with Exp_Dist; use Exp_Dist;
  36 with Exp_Imgv; use Exp_Imgv;
  37 with Exp_Pakd; use Exp_Pakd;
  38 with Exp_Strm; use Exp_Strm;
  39 with Exp_Tss;  use Exp_Tss;
  40 with Exp_Util; use Exp_Util;
  41 with Exp_VFpt; use Exp_VFpt;
  42 with Fname;    use Fname;
  43 with Freeze;   use Freeze;
  44 with Gnatvsn;  use Gnatvsn;
  45 with Itypes;   use Itypes;
  46 with Lib;      use Lib;
  47 with Namet;    use Namet;
  48 with Nmake;    use Nmake;
  49 with Nlists;   use Nlists;
  50 with Opt;      use Opt;
  51 with Restrict; use Restrict;
  52 with Rident;   use Rident;
  53 with Rtsfind;  use Rtsfind;
  54 with Sem;      use Sem;
  55 with Sem_Aux;  use Sem_Aux;
  56 with Sem_Ch6;  use Sem_Ch6;
  57 with Sem_Ch7;  use Sem_Ch7;
  58 with Sem_Ch8;  use Sem_Ch8;
  59 with Sem_Eval; use Sem_Eval;
  60 with Sem_Res;  use Sem_Res;
  61 with Sem_Util; use Sem_Util;
  62 with Sinfo;    use Sinfo;
  63 with Snames;   use Snames;
  64 with Stand;    use Stand;
  65 with Stringt;  use Stringt;
  66 with Targparm; use Targparm;
  67 with Tbuild;   use Tbuild;
  68 with Ttypes;   use Ttypes;
  69 with Uintp;    use Uintp;
  70 with Uname;    use Uname;
  71 with Validsw;  use Validsw;
  72
  73 package body Exp_Attr is
  74
  75    -----------------------
  76    -- Local Subprograms --
  77    -----------------------
  78
  79    procedure Compile_Stream_Body_In_Scope
  80      (N     : Node_Id;
  81       Decl  : Node_Id;
  82       Arr   : Entity_Id;
  83       Check : Boolean);
  84    --  The body for a stream subprogram may be generated outside of the scope
  85    --  of the type. If the type is fully private, it may depend on the full
  86    --  view of other types (e.g. indexes) that are currently private as well.
  87    --  We install the declarations of the package in which the type is declared
  88    --  before compiling the body in what is its proper environment. The Check
  89    --  parameter indicates if checks are to be suppressed for the stream body.
  90    --  We suppress checks for array/record reads, since the rule is that these
  91    --  are like assignments, out of range values due to uninitialized storage,
  92    --  or other invalid values do NOT cause a Constraint_Error to be raised.
  93
  94    procedure Expand_Access_To_Protected_Op
  95      (N    : Node_Id;
  96       Pref : Node_Id;
  97       Typ  : Entity_Id);
  98    --  An attribute reference to a protected subprogram is transformed into
  99    --  a pair of pointers: one to the object, and one to the operations.
 100    --  This expansion is performed for 'Access and for 'Unrestricted_Access.
 101
 102    procedure Expand_Fpt_Attribute
 103      (N    : Node_Id;
 104       Pkg  : RE_Id;
 105       Nam  : Name_Id;
 106       Args : List_Id);
 107    --  This procedure expands a call to a floating-point attribute function.
 108    --  N is the attribute reference node, and Args is a list of arguments to
 109    --  be passed to the function call. Pkg identifies the package containing
 110    --  the appropriate instantiation of System.Fat_Gen. Float arguments in Args
 111    --  have already been converted to the floating-point type for which Pkg was
 112    --  instantiated. The Nam argument is the relevant attribute processing
 113    --  routine to be called. This is the same as the attribute name, except in
 114    --  the Unaligned_Valid case.
 115
 116    procedure Expand_Fpt_Attribute_R (N : Node_Id);
 117    --  This procedure expands a call to a floating-point attribute function
 118    --  that takes a single floating-point argument. The function to be called
 119    --  is always the same as the attribute name.
 120
 121    procedure Expand_Fpt_Attribute_RI (N : Node_Id);
 122    --  This procedure expands a call to a floating-point attribute function
 123    --  that takes one floating-point argument and one integer argument. The
 124    --  function to be called is always the same as the attribute name.
 125
 126    procedure Expand_Fpt_Attribute_RR (N : Node_Id);
 127    --  This procedure expands a call to a floating-point attribute function
 128    --  that takes two floating-point arguments. The function to be called
 129    --  is always the same as the attribute name.
 130
 131    procedure Expand_Pred_Succ (N : Node_Id);
 132    --  Handles expansion of Pred or Succ attributes for case of non-real
 133    --  operand with overflow checking required.
 134
 135    function Get_Index_Subtype (N : Node_Id) return Entity_Id;
 136    --  Used for Last, Last, and Length, when the prefix is an array type.
 137    --  Obtains the corresponding index subtype.
 138
 139    procedure Find_Fat_Info
 140      (T        : Entity_Id;
 141       Fat_Type : out Entity_Id;
 142       Fat_Pkg  : out RE_Id);
 143    --  Given a floating-point type T, identifies the package containing the
 144    --  attributes for this type (returned in Fat_Pkg), and the corresponding
 145    --  type for which this package was instantiated from Fat_Gen. Error if T
 146    --  is not a floating-point type.
 147
 148    function Find_Stream_Subprogram
 149      (Typ : Entity_Id;
 150       Nam : TSS_Name_Type) return Entity_Id;
 151    --  Returns the stream-oriented subprogram attribute for Typ. For tagged
 152    --  types, the corresponding primitive operation is looked up, else the
 153    --  appropriate TSS from the type itself, or from its closest ancestor
 154    --  defining it, is returned. In both cases, inheritance of representation
 155    --  aspects is thus taken into account.
 156
 157    function Full_Base (T : Entity_Id) return Entity_Id;
 158    --  The stream functions need to examine the underlying representation of
 159    --  composite types. In some cases T may be non-private but its base type
 160    --  is, in which case the function returns the corresponding full view.
 161
 162    function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id;
 163    --  Given a type, find a corresponding stream convert pragma that applies to
 164    --  the implementation base type of this type (Typ). If found, return the
 165    --  pragma node, otherwise return Empty if no pragma is found.
 166
 167    function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
 168    --  Utility for array attributes, returns true on packed constrained
 169    --  arrays, and on access to same.
 170
 171    function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean;
 172    --  Returns true iff the given node refers to an attribute call that
 173    --  can be expanded directly by the back end and does not need front end
 174    --  expansion. Typically used for rounding and truncation attributes that
 175    --  appear directly inside a conversion to integer.
 176
 177    ----------------------------------
 178    -- Compile_Stream_Body_In_Scope --
 179    ----------------------------------
 180
 181    procedure Compile_Stream_Body_In_Scope
 182      (N     : Node_Id;
 183       Decl  : Node_Id;
 184       Arr   : Entity_Id;
 185       Check : Boolean)
 186    is
 187       Installed : Boolean := False;
 188       Scop      : constant Entity_Id := Scope (Arr);
 189       Curr      : constant Entity_Id := Current_Scope;
 190
 191    begin
 192       if Is_Hidden (Arr)
 193         and then not In_Open_Scopes (Scop)
 194         and then Ekind (Scop) = E_Package
 195       then
 196          Push_Scope (Scop);
 197          Install_Visible_Declarations (Scop);
 198          Install_Private_Declarations (Scop);
 199          Installed := True;
 200
 201          --  The entities in the package are now visible, but the generated
 202          --  stream entity must appear in the current scope (usually an
 203          --  enclosing stream function) so that itypes all have their proper
 204          --  scopes.
 205
 206          Push_Scope (Curr);
 207       end if;
 208
 209       if Check then
 210          Insert_Action (N, Decl);
 211       else
 212          Insert_Action (N, Decl, Suppress => All_Checks);
 213       end if;
 214
 215       if Installed then
 216
 217          --  Remove extra copy of current scope, and package itself
 218
 219          Pop_Scope;
 220          End_Package_Scope (Scop);
 221       end if;
 222    end Compile_Stream_Body_In_Scope;
 223
 224    -----------------------------------
 225    -- Expand_Access_To_Protected_Op --
 226    -----------------------------------
 227
 228    procedure Expand_Access_To_Protected_Op
 229      (N    : Node_Id;
 230       Pref : Node_Id;
 231       Typ  : Entity_Id)
 232    is
 233       --  The value of the attribute_reference is a record containing two
 234       --  fields: an access to the protected object, and an access to the
 235       --  subprogram itself. The prefix is a selected component.
 236
 237       Loc     : constant Source_Ptr := Sloc (N);
 238       Agg     : Node_Id;
 239       Btyp    : constant Entity_Id := Base_Type (Typ);
 240       Sub     : Entity_Id;
 241       Sub_Ref : Node_Id;
 242       E_T     : constant Entity_Id := Equivalent_Type (Btyp);
 243       Acc     : constant Entity_Id :=
 244                   Etype (Next_Component (First_Component (E_T)));
 245       Obj_Ref : Node_Id;
 246       Curr    : Entity_Id;
 247
 248       function May_Be_External_Call return Boolean;
 249       --  If the 'Access is to a local operation, but appears in a context
 250       --  where it may lead to a call from outside the object, we must treat
 251       --  this as an external call. Clearly we cannot tell without full
 252       --  flow analysis, and a subsequent call that uses this 'Access may
 253       --  lead to a bounded error (trying to seize locks twice, e.g.). For
 254       --  now we treat 'Access as a potential external call if it is an actual
 255       --  in a call to an outside subprogram.
 256
 257       --------------------------
 258       -- May_Be_External_Call --
 259       --------------------------
 260
 261       function May_Be_External_Call return Boolean is
 262          Subp : Entity_Id;
 263          Par  : Node_Id := Parent (N);
 264
 265       begin
 266          --  Account for the case where the Access attribute is part of a
 267          --  named parameter association.
 268
 269          if Nkind (Par) = N_Parameter_Association then
 270             Par := Parent (Par);
 271          end if;
 272
 273          if Nkind_In (Par, N_Procedure_Call_Statement, N_Function_Call)
 274             and then Is_Entity_Name (Name (Par))
 275          then
 276             Subp := Entity (Name (Par));
 277             return not In_Open_Scopes (Scope (Subp));
 278          else
 279             return False;
 280          end if;
 281       end May_Be_External_Call;
 282
 283    --  Start of processing for Expand_Access_To_Protected_Op
 284
 285    begin
 286       --  Within the body of the protected type, the prefix designates a local
 287       --  operation, and the object is the first parameter of the corresponding
 288       --  protected body of the current enclosing operation.
 289
 290       if Is_Entity_Name (Pref) then
 291          if May_Be_External_Call then
 292             Sub :=
 293               New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc);
 294          else
 295             Sub :=
 296               New_Occurrence_Of
 297                 (Protected_Body_Subprogram (Entity (Pref)), Loc);
 298          end if;
 299
 300          --  Don't traverse the scopes when the attribute occurs within an init
 301          --  proc, because we directly use the _init formal of the init proc in
 302          --  that case.
 303
 304          Curr := Current_Scope;
 305          if not Is_Init_Proc (Curr) then
 306             pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
 307
 308             while Scope (Curr) /= Scope (Entity (Pref)) loop
 309                Curr := Scope (Curr);
 310             end loop;
 311          end if;
 312
 313          --  In case of protected entries the first formal of its Protected_
 314          --  Body_Subprogram is the address of the object.
 315
 316          if Ekind (Curr) = E_Entry then
 317             Obj_Ref :=
 318                New_Occurrence_Of
 319                  (First_Formal
 320                    (Protected_Body_Subprogram (Curr)), Loc);
 321
 322          --  If the current scope is an init proc, then use the address of the
 323          --  _init formal as the object reference.
 324
 325          elsif Is_Init_Proc (Curr) then
 326             Obj_Ref :=
 327               Make_Attribute_Reference (Loc,
 328                 Prefix         => New_Occurrence_Of (First_Formal (Curr), Loc),
 329                 Attribute_Name => Name_Address);
 330
 331          --  In case of protected subprograms the first formal of its
 332          --  Protected_Body_Subprogram is the object and we get its address.
 333
 334          else
 335             Obj_Ref :=
 336               Make_Attribute_Reference (Loc,
 337                 Prefix =>
 338                    New_Occurrence_Of
 339                      (First_Formal
 340                         (Protected_Body_Subprogram (Curr)), Loc),
 341                 Attribute_Name => Name_Address);
 342          end if;
 343
 344       --  Case where the prefix is not an entity name. Find the
 345       --  version of the protected operation to be called from
 346       --  outside the protected object.
 347
 348       else
 349          Sub :=
 350            New_Occurrence_Of
 351              (External_Subprogram
 352                (Entity (Selector_Name (Pref))), Loc);
 353
 354          Obj_Ref :=
 355            Make_Attribute_Reference (Loc,
 356              Prefix => Relocate_Node (Prefix (Pref)),
 357                Attribute_Name => Name_Address);
 358       end if;
 359
 360       Sub_Ref :=
 361         Make_Attribute_Reference (Loc,
 362           Prefix         => Sub,
 363           Attribute_Name => Name_Access);
 364
 365       --  We set the type of the access reference to the already generated
 366       --  access_to_subprogram type, and declare the reference analyzed, to
 367       --  prevent further expansion when the enclosing aggregate is analyzed.
 368
 369       Set_Etype (Sub_Ref, Acc);
 370       Set_Analyzed (Sub_Ref);
 371
 372       Agg :=
 373         Make_Aggregate (Loc,
 374           Expressions => New_List (Obj_Ref, Sub_Ref));
 375
 376       --  Sub_Ref has been marked as analyzed, but we still need to make sure
 377       --  Sub is correctly frozen.
 378
 379       Freeze_Before (N, Entity (Sub));
 380
 381       Rewrite (N, Agg);
 382       Analyze_And_Resolve (N, E_T);
 383
 384       --  For subsequent analysis, the node must retain its type. The backend
 385       --  will replace it with the equivalent type where needed.
 386
 387       Set_Etype (N, Typ);
 388    end Expand_Access_To_Protected_Op;
 389
 390    --------------------------
 391    -- Expand_Fpt_Attribute --
 392    --------------------------
 393
 394    procedure Expand_Fpt_Attribute
 395      (N    : Node_Id;
 396       Pkg  : RE_Id;
 397       Nam  : Name_Id;
 398       Args : List_Id)
 399    is
 400       Loc : constant Source_Ptr := Sloc (N);
 401       Typ : constant Entity_Id  := Etype (N);
 402       Fnm : Node_Id;
 403
 404    begin
 405       --  The function name is the selected component Attr_xxx.yyy where
 406       --  Attr_xxx is the package name, and yyy is the argument Nam.
 407
 408       --  Note: it would be more usual to have separate RE entries for each
 409       --  of the entities in the Fat packages, but first they have identical
 410       --  names (so we would have to have lots of renaming declarations to
 411       --  meet the normal RE rule of separate names for all runtime entities),
 412       --  and second there would be an awful lot of them!
 413
 414       Fnm :=
 415         Make_Selected_Component (Loc,
 416           Prefix        => New_Reference_To (RTE (Pkg), Loc),
 417           Selector_Name => Make_Identifier (Loc, Nam));
 418
 419       --  The generated call is given the provided set of parameters, and then
 420       --  wrapped in a conversion which converts the result to the target type
 421       --  We use the base type as the target because a range check may be
 422       --  required.
 423
 424       Rewrite (N,
 425         Unchecked_Convert_To (Base_Type (Etype (N)),
 426           Make_Function_Call (Loc,
 427             Name                   => Fnm,
 428             Parameter_Associations => Args)));
 429
 430       Analyze_And_Resolve (N, Typ);
 431    end Expand_Fpt_Attribute;
 432
 433    ----------------------------
 434    -- Expand_Fpt_Attribute_R --
 435    ----------------------------
 436
 437    --  The single argument is converted to its root type to call the
 438    --  appropriate runtime function, with the actual call being built
 439    --  by Expand_Fpt_Attribute
 440
 441    procedure Expand_Fpt_Attribute_R (N : Node_Id) is
 442       E1  : constant Node_Id    := First (Expressions (N));
 443       Ftp : Entity_Id;
 444       Pkg : RE_Id;
 445    begin
 446       Find_Fat_Info (Etype (E1), Ftp, Pkg);
 447       Expand_Fpt_Attribute
 448         (N, Pkg, Attribute_Name (N),
 449          New_List (Unchecked_Convert_To (Ftp, Relocate_Node (E1))));
 450    end Expand_Fpt_Attribute_R;
 451
 452    -----------------------------
 453    -- Expand_Fpt_Attribute_RI --
 454    -----------------------------
 455
 456    --  The first argument is converted to its root type and the second
 457    --  argument is converted to standard long long integer to call the
 458    --  appropriate runtime function, with the actual call being built
 459    --  by Expand_Fpt_Attribute
 460
 461    procedure Expand_Fpt_Attribute_RI (N : Node_Id) is
 462       E1  : constant Node_Id   := First (Expressions (N));
 463       Ftp : Entity_Id;
 464       Pkg : RE_Id;
 465       E2  : constant Node_Id   := Next (E1);
 466    begin
 467       Find_Fat_Info (Etype (E1), Ftp, Pkg);
 468       Expand_Fpt_Attribute
 469         (N, Pkg, Attribute_Name (N),
 470          New_List (
 471            Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
 472            Unchecked_Convert_To (Standard_Integer, Relocate_Node (E2))));
 473    end Expand_Fpt_Attribute_RI;
 474
 475    -----------------------------
 476    -- Expand_Fpt_Attribute_RR --
 477    -----------------------------
 478
 479    --  The two arguments are converted to their root types to call the
 480    --  appropriate runtime function, with the actual call being built
 481    --  by Expand_Fpt_Attribute
 482
 483    procedure Expand_Fpt_Attribute_RR (N : Node_Id) is
 484       E1  : constant Node_Id   := First (Expressions (N));
 485       Ftp : Entity_Id;
 486       Pkg : RE_Id;
 487       E2  : constant Node_Id   := Next (E1);
 488    begin
 489       Find_Fat_Info (Etype (E1), Ftp, Pkg);
 490       Expand_Fpt_Attribute
 491         (N, Pkg, Attribute_Name (N),
 492          New_List (
 493            Unchecked_Convert_To (Ftp, Relocate_Node (E1)),
 494            Unchecked_Convert_To (Ftp, Relocate_Node (E2))));
 495    end Expand_Fpt_Attribute_RR;
 496
 497    ----------------------------------
 498    -- Expand_N_Attribute_Reference --
 499    ----------------------------------
 500
 501    procedure Expand_N_Attribute_Reference (N : Node_Id) is
 502       Loc   : constant Source_Ptr   := Sloc (N);
 503       Typ   : constant Entity_Id    := Etype (N);
 504       Btyp  : constant Entity_Id    := Base_Type (Typ);
 505       Pref  : constant Node_Id      := Prefix (N);
 506       Ptyp  : constant Entity_Id    := Etype (Pref);
 507       Exprs : constant List_Id      := Expressions (N);
 508       Id    : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
 509
 510       procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
 511       --  Rewrites a stream attribute for Read, Write or Output with the
 512       --  procedure call. Pname is the entity for the procedure to call.
 513
 514       ------------------------------
 515       -- Rewrite_Stream_Proc_Call --
 516       ------------------------------
 517
 518       procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
 519          Item       : constant Node_Id   := Next (First (Exprs));
 520          Formal     : constant Entity_Id := Next_Formal (First_Formal (Pname));
 521          Formal_Typ : constant Entity_Id := Etype (Formal);
 522          Is_Written : constant Boolean   := (Ekind (Formal) /= E_In_Parameter);
 523
 524       begin
 525          --  The expansion depends on Item, the second actual, which is
 526          --  the object being streamed in or out.
 527
 528          --  If the item is a component of a packed array type, and
 529          --  a conversion is needed on exit, we introduce a temporary to
 530          --  hold the value, because otherwise the packed reference will
 531          --  not be properly expanded.
 532
 533          if Nkind (Item) = N_Indexed_Component
 534            and then Is_Packed (Base_Type (Etype (Prefix (Item))))
 535            and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
 536            and then Is_Written
 537          then
 538             declare
 539                Temp : constant Entity_Id := Make_Temporary (Loc, 'V');
 540                Decl : Node_Id;
 541                Assn : Node_Id;
 542
 543             begin
 544                Decl :=
 545                  Make_Object_Declaration (Loc,
 546                    Defining_Identifier => Temp,
 547                    Object_Definition    =>
 548                      New_Occurrence_Of (Formal_Typ, Loc));
 549                Set_Etype (Temp, Formal_Typ);
 550
 551                Assn :=
 552                  Make_Assignment_Statement (Loc,
 553                    Name => New_Copy_Tree (Item),
 554                    Expression =>
 555                      Unchecked_Convert_To
 556                        (Etype (Item), New_Occurrence_Of (Temp, Loc)));
 557
 558                Rewrite (Item, New_Occurrence_Of (Temp, Loc));
 559                Insert_Actions (N,
 560                  New_List (
 561                    Decl,
 562                    Make_Procedure_Call_Statement (Loc,
 563                      Name => New_Occurrence_Of (Pname, Loc),
 564                      Parameter_Associations => Exprs),
 565                    Assn));
 566
 567                Rewrite (N, Make_Null_Statement (Loc));
 568                return;
 569             end;
 570          end if;
 571
 572          --  For the class-wide dispatching cases, and for cases in which
 573          --  the base type of the second argument matches the base type of
 574          --  the corresponding formal parameter (that is to say the stream
 575          --  operation is not inherited), we are all set, and can use the
 576          --  argument unchanged.
 577
 578          --  For all other cases we do an unchecked conversion of the second
 579          --  parameter to the type of the formal of the procedure we are
 580          --  calling. This deals with the private type cases, and with going
 581          --  to the root type as required in elementary type case.
 582
 583          if not Is_Class_Wide_Type (Entity (Pref))
 584            and then not Is_Class_Wide_Type (Etype (Item))
 585            and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
 586          then
 587             Rewrite (Item,
 588               Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
 589
 590             --  For untagged derived types set Assignment_OK, to prevent
 591             --  copies from being created when the unchecked conversion
 592             --  is expanded (which would happen in Remove_Side_Effects
 593             --  if Expand_N_Unchecked_Conversion were allowed to call
 594             --  Force_Evaluation). The copy could violate Ada semantics
 595             --  in cases such as an actual that is an out parameter.
 596             --  Note that this approach is also used in exp_ch7 for calls
 597             --  to controlled type operations to prevent problems with
 598             --  actuals wrapped in unchecked conversions.
 599
 600             if Is_Untagged_Derivation (Etype (Expression (Item))) then
 601                Set_Assignment_OK (Item);
 602             end if;
 603          end if;
 604
 605          --  The stream operation to call maybe a renaming created by
 606          --  an attribute definition clause, and may not be frozen yet.
 607          --  Ensure that it has the necessary extra formals.
 608
 609          if not Is_Frozen (Pname) then
 610             Create_Extra_Formals (Pname);
 611          end if;
 612
 613          --  And now rewrite the call
 614
 615          Rewrite (N,
 616            Make_Procedure_Call_Statement (Loc,
 617              Name => New_Occurrence_Of (Pname, Loc),
 618              Parameter_Associations => Exprs));
 619
 620          Analyze (N);
 621       end Rewrite_Stream_Proc_Call;
 622
 623    --  Start of processing for Expand_N_Attribute_Reference
 624
 625    begin
 626       --  Do required validity checking, if enabled. Do not apply check to
 627       --  output parameters of an Asm instruction, since the value of this
 628       --  is not set till after the attribute has been elaborated, and do
 629       --  not apply the check to the arguments of a 'Read or 'Input attribute
 630       --  reference since the scalar argument is an OUT scalar.
 631
 632       if Validity_Checks_On and then Validity_Check_Operands
 633         and then Id /= Attribute_Asm_Output
 634         and then Id /= Attribute_Read
 635         and then Id /= Attribute_Input
 636       then
 637          declare
 638             Expr : Node_Id;
 639          begin
 640             Expr := First (Expressions (N));
 641             while Present (Expr) loop
 642                Ensure_Valid (Expr);
 643                Next (Expr);
 644             end loop;
 645          end;
 646       end if;
 647
 648       --  Ada 2005 (AI-318-02): If attribute prefix is a call to a build-in-
 649       --  place function, then a temporary return object needs to be created
 650       --  and access to it must be passed to the function. Currently we limit
 651       --  such functions to those with inherently limited result subtypes, but
 652       --  eventually we plan to expand the functions that are treated as
 653       --  build-in-place to include other composite result types.
 654
 655       if Ada_Version >= Ada_2005
 656         and then Is_Build_In_Place_Function_Call (Pref)
 657       then
 658          Make_Build_In_Place_Call_In_Anonymous_Context (Pref);
 659       end if;
 660
 661       --  If prefix is a protected type name, this is a reference to the
 662       --  current instance of the type. For a component definition, nothing
 663       --  to do (expansion will occur in the init proc). In other contexts,
 664       --  rewrite into reference to current instance.
 665
 666       if Is_Protected_Self_Reference (Pref)
 667            and then not
 668              (Nkind_In (Parent (N), N_Index_Or_Discriminant_Constraint,
 669                                     N_Discriminant_Association)
 670                 and then Nkind (Parent (Parent (Parent (Parent (N))))) =
 671                                                       N_Component_Definition)
 672       then
 673          Rewrite (Pref, Concurrent_Ref (Pref));
 674          Analyze (Pref);
 675       end if;
 676
 677       --  Remaining processing depends on specific attribute
 678
 679       case Id is
 680
 681          --  Attributes related to Ada2012 iterators (Placeholder)
 682
 683          when Attribute_Constant_Indexing => null;
 684          when Attribute_Default_Iterator => null;
 685          when Attribute_Implicit_Dereference => null;
 686          when Attribute_Iterator_Element => null;
 687          when Attribute_Variable_Indexing => null;
 688
 689       ------------
 690       -- Access --
 691       ------------
 692
 693       when Attribute_Access              |
 694            Attribute_Unchecked_Access    |
 695            Attribute_Unrestricted_Access =>
 696
 697          Access_Cases : declare
 698             Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
 699             Btyp_DDT   : Entity_Id;
 700
 701             function Enclosing_Object (N : Node_Id) return Node_Id;
 702             --  If N denotes a compound name (selected component, indexed
 703             --  component, or slice), returns the name of the outermost such
 704             --  enclosing object. Otherwise returns N. If the object is a
 705             --  renaming, then the renamed object is returned.
 706
 707             ----------------------
 708             -- Enclosing_Object --
 709             ----------------------
 710
 711             function Enclosing_Object (N : Node_Id) return Node_Id is
 712                Obj_Name : Node_Id;
 713
 714             begin
 715                Obj_Name := N;
 716                while Nkind_In (Obj_Name, N_Selected_Component,
 717                                          N_Indexed_Component,
 718                                          N_Slice)
 719                loop
 720                   Obj_Name := Prefix (Obj_Name);
 721                end loop;
 722
 723                return Get_Referenced_Object (Obj_Name);
 724             end Enclosing_Object;
 725
 726             --  Local declarations
 727
 728             Enc_Object : constant Node_Id := Enclosing_Object (Ref_Object);
 729
 730          --  Start of processing for Access_Cases
 731
 732          begin
 733             Btyp_DDT := Designated_Type (Btyp);
 734
 735             --  Handle designated types that come from the limited view
 736
 737             if Ekind (Btyp_DDT) = E_Incomplete_Type
 738               and then From_With_Type (Btyp_DDT)
 739               and then Present (Non_Limited_View (Btyp_DDT))
 740             then
 741                Btyp_DDT := Non_Limited_View (Btyp_DDT);
 742
 743             elsif Is_Class_Wide_Type (Btyp_DDT)
 744                and then Ekind (Etype (Btyp_DDT)) = E_Incomplete_Type
 745                and then From_With_Type (Etype (Btyp_DDT))
 746                and then Present (Non_Limited_View (Etype (Btyp_DDT)))
 747                and then Present (Class_Wide_Type
 748                                   (Non_Limited_View (Etype (Btyp_DDT))))
 749             then
 750                Btyp_DDT :=
 751                  Class_Wide_Type (Non_Limited_View (Etype (Btyp_DDT)));
 752             end if;
 753
 754             --  In order to improve the text of error messages, the designated
 755             --  type of access-to-subprogram itypes is set by the semantics as
 756             --  the associated subprogram entity (see sem_attr). Now we replace
 757             --  such node with the proper E_Subprogram_Type itype.
 758
 759             if Id = Attribute_Unrestricted_Access
 760               and then Is_Subprogram (Directly_Designated_Type (Typ))
 761             then
 762                --  The following conditions ensure that this special management
 763                --  is done only for "Address!(Prim'Unrestricted_Access)" nodes.
 764                --  At this stage other cases in which the designated type is
 765                --  still a subprogram (instead of an E_Subprogram_Type) are
 766                --  wrong because the semantics must have overridden the type of
 767                --  the node with the type imposed by the context.
 768
 769                if Nkind (Parent (N)) = N_Unchecked_Type_Conversion
 770                  and then Etype (Parent (N)) = RTE (RE_Prim_Ptr)
 771                then
 772                   Set_Etype (N, RTE (RE_Prim_Ptr));
 773
 774                else
 775                   declare
 776                      Subp       : constant Entity_Id :=
 777                                     Directly_Designated_Type (Typ);
 778                      Etyp       : Entity_Id;
 779                      Extra      : Entity_Id := Empty;
 780                      New_Formal : Entity_Id;
 781                      Old_Formal : Entity_Id := First_Formal (Subp);
 782                      Subp_Typ   : Entity_Id;
 783
 784                   begin
 785                      Subp_Typ := Create_Itype (E_Subprogram_Type, N);
 786                      Set_Etype (Subp_Typ, Etype (Subp));
 787                      Set_Returns_By_Ref (Subp_Typ, Returns_By_Ref (Subp));
 788
 789                      if Present (Old_Formal) then
 790                         New_Formal := New_Copy (Old_Formal);
 791                         Set_First_Entity (Subp_Typ, New_Formal);
 792
 793                         loop
 794                            Set_Scope (New_Formal, Subp_Typ);
 795                            Etyp := Etype (New_Formal);
 796
 797                            --  Handle itypes. There is no need to duplicate
 798                            --  here the itypes associated with record types
 799                            --  (i.e the implicit full view of private types).
 800
 801                            if Is_Itype (Etyp)
 802                              and then Ekind (Base_Type (Etyp)) /= E_Record_Type
 803                            then
 804                               Extra := New_Copy (Etyp);
 805                               Set_Parent (Extra, New_Formal);
 806                               Set_Etype (New_Formal, Extra);
 807                               Set_Scope (Extra, Subp_Typ);
 808                            end if;
 809
 810                            Extra := New_Formal;
 811                            Next_Formal (Old_Formal);
 812                            exit when No (Old_Formal);
 813
 814                            Set_Next_Entity (New_Formal,
 815                              New_Copy (Old_Formal));
 816                            Next_Entity (New_Formal);
 817                         end loop;
 818
 819                         Set_Next_Entity (New_Formal, Empty);
 820                         Set_Last_Entity (Subp_Typ, Extra);
 821                      end if;
 822
 823                      --  Now that the explicit formals have been duplicated,
 824                      --  any extra formals needed by the subprogram must be
 825                      --  created.
 826
 827                      if Present (Extra) then
 828                         Set_Extra_Formal (Extra, Empty);
 829                      end if;
 830
 831                      Create_Extra_Formals (Subp_Typ);
 832                      Set_Directly_Designated_Type (Typ, Subp_Typ);
 833                   end;
 834                end if;
 835             end if;
 836
 837             if Is_Access_Protected_Subprogram_Type (Btyp) then
 838                Expand_Access_To_Protected_Op (N, Pref, Typ);
 839
 840             --  If prefix is a type name, this is a reference to the current
 841             --  instance of the type, within its initialization procedure.
 842
 843             elsif Is_Entity_Name (Pref)
 844               and then Is_Type (Entity (Pref))
 845             then
 846                declare
 847                   Par    : Node_Id;
 848                   Formal : Entity_Id;
 849
 850                begin
 851                   --  If the current instance name denotes a task type, then
 852                   --  the access attribute is rewritten to be the name of the
 853                   --  "_task" parameter associated with the task type's task
 854                   --  procedure. An unchecked conversion is applied to ensure
 855                   --  a type match in cases of expander-generated calls (e.g.
 856                   --  init procs).
 857
 858                   if Is_Task_Type (Entity (Pref)) then
 859                      Formal :=
 860                        First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
 861                      while Present (Formal) loop
 862                         exit when Chars (Formal) = Name_uTask;
 863                         Next_Entity (Formal);
 864                      end loop;
 865
 866                      pragma Assert (Present (Formal));
 867
 868                      Rewrite (N,
 869                        Unchecked_Convert_To (Typ,
 870                          New_Occurrence_Of (Formal, Loc)));
 871                      Set_Etype (N, Typ);
 872
 873                      --  The expression must appear in a default expression,
 874                      --  (which in the initialization procedure is the
 875                      --  right-hand side of an assignment), and not in a
 876                      --  discriminant constraint.
 877
 878                   else
 879                      Par := Parent (N);
 880                      while Present (Par) loop
 881                         exit when Nkind (Par) = N_Assignment_Statement;
 882
 883                         if Nkind (Par) = N_Component_Declaration then
 884                            return;
 885                         end if;
 886
 887                         Par := Parent (Par);
 888                      end loop;
 889
 890                      if Present (Par) then
 891                         Rewrite (N,
 892                           Make_Attribute_Reference (Loc,
 893                             Prefix => Make_Identifier (Loc, Name_uInit),
 894                             Attribute_Name  => Attribute_Name (N)));
 895
 896                         Analyze_And_Resolve (N, Typ);
 897                      end if;
 898                   end if;
 899                end;
 900
 901             --  If the prefix of an Access attribute is a dereference of an
 902             --  access parameter (or a renaming of such a dereference, or a
 903             --  subcomponent of such a dereference) and the context is a
 904             --  general access type (including the type of an object or
 905             --  component with an access_definition, but not the anonymous
 906             --  type of an access parameter or access discriminant), then
 907             --  apply an accessibility check to the access parameter. We used
 908             --  to rewrite the access parameter as a type conversion, but that
 909             --  could only be done if the immediate prefix of the Access
 910             --  attribute was the dereference, and didn't handle cases where
 911             --  the attribute is applied to a subcomponent of the dereference,
 912             --  since there's generally no available, appropriate access type
 913             --  to convert to in that case. The attribute is passed as the
 914             --  point to insert the check, because the access parameter may
 915             --  come from a renaming, possibly in a different scope, and the
 916             --  check must be associated with the attribute itself.
 917
 918             elsif Id = Attribute_Access
 919               and then Nkind (Enc_Object) = N_Explicit_Dereference
 920               and then Is_Entity_Name (Prefix (Enc_Object))
 921               and then (Ekind (Btyp) = E_General_Access_Type
 922                          or else Is_Local_Anonymous_Access (Btyp))
 923               and then Ekind (Entity (Prefix (Enc_Object))) in Formal_Kind
 924               and then Ekind (Etype (Entity (Prefix (Enc_Object))))
 925                          = E_Anonymous_Access_Type
 926               and then Present (Extra_Accessibility
 927                                 (Entity (Prefix (Enc_Object))))
 928             then
 929                Apply_Accessibility_Check (Prefix (Enc_Object), Typ, N);
 930
 931             --  Ada 2005 (AI-251): If the designated type is an interface we
 932             --  add an implicit conversion to force the displacement of the
 933             --  pointer to reference the secondary dispatch table.
 934
 935             elsif Is_Interface (Btyp_DDT)
 936               and then (Comes_From_Source (N)
 937                          or else Comes_From_Source (Ref_Object)
 938                          or else (Nkind (Ref_Object) in N_Has_Chars
 939                                    and then Chars (Ref_Object) = Name_uInit))
 940             then
 941                if Nkind (Ref_Object) /= N_Explicit_Dereference then
 942
 943                   --  No implicit conversion required if types match, or if
 944                   --  the prefix is the class_wide_type of the interface. In
 945                   --  either case passing an object of the interface type has
 946                   --  already set the pointer correctly.
 947
 948                   if Btyp_DDT = Etype (Ref_Object)
 949                     or else (Is_Class_Wide_Type (Etype (Ref_Object))
 950                               and then
 951                                Class_Wide_Type (Btyp_DDT) = Etype (Ref_Object))
 952                   then
 953                      null;
 954
 955                   else
 956                      Rewrite (Prefix (N),
 957                        Convert_To (Btyp_DDT,
 958                          New_Copy_Tree (Prefix (N))));
 959
 960                      Analyze_And_Resolve (Prefix (N), Btyp_DDT);
 961                   end if;
 962
 963                --  When the object is an explicit dereference, convert the
 964                --  dereference's prefix.
 965
 966                else
 967                   declare
 968                      Obj_DDT : constant Entity_Id :=
 969                                  Base_Type
 970                                    (Directly_Designated_Type
 971                                      (Etype (Prefix (Ref_Object))));
 972                   begin
 973                      --  No implicit conversion required if designated types
 974                      --  match.
 975
 976                      if Obj_DDT /= Btyp_DDT
 977                        and then not (Is_Class_Wide_Type (Obj_DDT)
 978                                        and then Etype (Obj_DDT) = Btyp_DDT)
 979                      then
 980                         Rewrite (N,
 981                           Convert_To (Typ,
 982                             New_Copy_Tree (Prefix (Ref_Object))));
 983                         Analyze_And_Resolve (N, Typ);
 984                      end if;
 985                   end;
 986                end if;
 987             end if;
 988          end Access_Cases;
 989
 990       --------------
 991       -- Adjacent --
 992       --------------
 993
 994       --  Transforms 'Adjacent into a call to the floating-point attribute
 995       --  function Adjacent in Fat_xxx (where xxx is the root type)
 996
 997       when Attribute_Adjacent =>
 998          Expand_Fpt_Attribute_RR (N);
 999
1000       -------------
1001       -- Address --
1002       -------------
1003
1004       when Attribute_Address => Address : declare
1005          Task_Proc : Entity_Id;
1006
1007       begin
1008          --  If the prefix is a task or a task type, the useful address is that
1009          --  of the procedure for the task body, i.e. the actual program unit.
1010          --  We replace the original entity with that of the procedure.
1011
1012          if Is_Entity_Name (Pref)
1013            and then Is_Task_Type (Entity (Pref))
1014          then
1015             Task_Proc := Next_Entity (Root_Type (Ptyp));
1016
1017             while Present (Task_Proc) loop
1018                exit when Ekind (Task_Proc) = E_Procedure
1019                  and then Etype (First_Formal (Task_Proc)) =
1020                                   Corresponding_Record_Type (Ptyp);
1021                Next_Entity (Task_Proc);
1022             end loop;
1023
1024             if Present (Task_Proc) then
1025                Set_Entity (Pref, Task_Proc);
1026                Set_Etype  (Pref, Etype (Task_Proc));
1027             end if;
1028
1029          --  Similarly, the address of a protected operation is the address
1030          --  of the corresponding protected body, regardless of the protected
1031          --  object from which it is selected.
1032
1033          elsif Nkind (Pref) = N_Selected_Component
1034            and then Is_Subprogram (Entity (Selector_Name (Pref)))
1035            and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref))))
1036          then
1037             Rewrite (Pref,
1038               New_Occurrence_Of (
1039                 External_Subprogram (Entity (Selector_Name (Pref))), Loc));
1040
1041          elsif Nkind (Pref) = N_Explicit_Dereference
1042            and then Ekind (Ptyp) = E_Subprogram_Type
1043            and then Convention (Ptyp) = Convention_Protected
1044          then
1045             --  The prefix is be a dereference of an access_to_protected_
1046             --  subprogram. The desired address is the second component of
1047             --  the record that represents the access.
1048
1049             declare
1050                Addr : constant Entity_Id := Etype (N);
1051                Ptr  : constant Node_Id   := Prefix (Pref);
1052                T    : constant Entity_Id :=
1053                         Equivalent_Type (Base_Type (Etype (Ptr)));
1054
1055             begin
1056                Rewrite (N,
1057                  Unchecked_Convert_To (Addr,
1058                    Make_Selected_Component (Loc,
1059                      Prefix => Unchecked_Convert_To (T, Ptr),
1060                      Selector_Name => New_Occurrence_Of (
1061                        Next_Entity (First_Entity (T)), Loc))));
1062
1063                Analyze_And_Resolve (N, Addr);
1064             end;
1065
1066          --  Ada 2005 (AI-251): Class-wide interface objects are always
1067          --  "displaced" to reference the tag associated with the interface
1068          --  type. In order to obtain the real address of such objects we
1069          --  generate a call to a run-time subprogram that returns the base
1070          --  address of the object.
1071
1072          --  This processing is not needed in the VM case, where dispatching
1073          --  issues are taken care of by the virtual machine.
1074
1075          elsif Is_Class_Wide_Type (Ptyp)
1076            and then Is_Interface (Ptyp)
1077            and then Tagged_Type_Expansion
1078            and then not (Nkind (Pref) in N_Has_Entity
1079                           and then Is_Subprogram (Entity (Pref)))
1080          then
1081             Rewrite (N,
1082               Make_Function_Call (Loc,
1083                 Name => New_Reference_To (RTE (RE_Base_Address), Loc),
1084                 Parameter_Associations => New_List (
1085                   Relocate_Node (N))));
1086             Analyze (N);
1087             return;
1088          end if;
1089
1090          --  Deal with packed array reference, other cases are handled by
1091          --  the back end.
1092
1093          if Involves_Packed_Array_Reference (Pref) then
1094             Expand_Packed_Address_Reference (N);
1095          end if;
1096       end Address;
1097
1098       ---------------
1099       -- Alignment --
1100       ---------------
1101
1102       when Attribute_Alignment => Alignment : declare
1103          New_Node : Node_Id;
1104
1105       begin
1106          --  For class-wide types, X'Class'Alignment is transformed into a
1107          --  direct reference to the Alignment of the class type, so that the
1108          --  back end does not have to deal with the X'Class'Alignment
1109          --  reference.
1110
1111          if Is_Entity_Name (Pref)
1112            and then Is_Class_Wide_Type (Entity (Pref))
1113          then
1114             Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
1115             return;
1116
1117          --  For x'Alignment applied to an object of a class wide type,
1118          --  transform X'Alignment into a call to the predefined primitive
1119          --  operation _Alignment applied to X.
1120
1121          elsif Is_Class_Wide_Type (Ptyp) then
1122
1123             --  No need to do anything else compiling under restriction
1124             --  No_Dispatching_Calls. During the semantic analysis we
1125             --  already notified such violation.
1126
1127             if Restriction_Active (No_Dispatching_Calls) then
1128                return;
1129             end if;
1130
1131             New_Node :=
1132               Make_Function_Call (Loc,
1133                 Name => New_Reference_To
1134                   (Find_Prim_Op (Ptyp, Name_uAlignment), Loc),
1135                 Parameter_Associations => New_List (Pref));
1136
1137             if Typ /= Standard_Integer then
1138
1139                --  The context is a specific integer type with which the
1140                --  original attribute was compatible. The function has a
1141                --  specific type as well, so to preserve the compatibility
1142                --  we must convert explicitly.
1143
1144                New_Node := Convert_To (Typ, New_Node);
1145             end if;
1146
1147             Rewrite (N, New_Node);
1148             Analyze_And_Resolve (N, Typ);
1149             return;
1150
1151          --  For all other cases, we just have to deal with the case of
1152          --  the fact that the result can be universal.
1153
1154          else
1155             Apply_Universal_Integer_Attribute_Checks (N);
1156          end if;
1157       end Alignment;
1158
1159       ---------------
1160       -- AST_Entry --
1161       ---------------
1162
1163       when Attribute_AST_Entry => AST_Entry : declare
1164          Ttyp : Entity_Id;
1165          T_Id : Node_Id;
1166          Eent : Entity_Id;
1167
1168          Entry_Ref : Node_Id;
1169          --  The reference to the entry or entry family
1170
1171          Index : Node_Id;
1172          --  The index expression for an entry family reference, or
1173          --  the Empty if Entry_Ref references a simple entry.
1174
1175       begin
1176          if Nkind (Pref) = N_Indexed_Component then
1177             Entry_Ref := Prefix (Pref);
1178             Index := First (Expressions (Pref));
1179          else
1180             Entry_Ref := Pref;
1181             Index := Empty;
1182          end if;
1183
1184          --  Get expression for Task_Id and the entry entity
1185
1186          if Nkind (Entry_Ref) = N_Selected_Component then
1187             T_Id :=
1188               Make_Attribute_Reference (Loc,
1189                 Attribute_Name => Name_Identity,
1190                 Prefix         => Prefix (Entry_Ref));
1191
1192             Ttyp := Etype (Prefix (Entry_Ref));
1193             Eent := Entity (Selector_Name (Entry_Ref));
1194
1195          else
1196             T_Id :=
1197               Make_Function_Call (Loc,
1198                 Name => New_Occurrence_Of (RTE (RE_Current_Task), Loc));
1199
1200             Eent  := Entity (Entry_Ref);
1201
1202             --  We have to find the enclosing task to get the task type
1203             --  There must be one, since we already validated this earlier
1204
1205             Ttyp := Current_Scope;
1206             while not Is_Task_Type (Ttyp) loop
1207                Ttyp := Scope (Ttyp);
1208             end loop;
1209          end if;
1210
1211          --  Now rewrite the attribute with a call to Create_AST_Handler
1212
1213          Rewrite (N,
1214            Make_Function_Call (Loc,
1215              Name => New_Occurrence_Of (RTE (RE_Create_AST_Handler), Loc),
1216              Parameter_Associations => New_List (
1217                T_Id,
1218                Entry_Index_Expression (Loc, Eent, Index, Ttyp))));
1219
1220          Analyze_And_Resolve (N, RTE (RE_AST_Handler));
1221       end AST_Entry;
1222
1223       ---------
1224       -- Bit --
1225       ---------
1226
1227       --  We compute this if a packed array reference was present, otherwise we
1228       --  leave the computation up to the back end.
1229
1230       when Attribute_Bit =>
1231          if Involves_Packed_Array_Reference (Pref) then
1232             Expand_Packed_Bit_Reference (N);
1233          else
1234             Apply_Universal_Integer_Attribute_Checks (N);
1235          end if;
1236
1237       ------------------
1238       -- Bit_Position --
1239       ------------------
1240
1241       --  We compute this if a component clause was present, otherwise we leave
1242       --  the computation up to the back end, since we don't know what layout
1243       --  will be chosen.
1244
1245       --  Note that the attribute can apply to a naked record component
1246       --  in generated code (i.e. the prefix is an identifier that
1247       --  references the component or discriminant entity).
1248
1249       when Attribute_Bit_Position => Bit_Position : declare
1250          CE : Entity_Id;
1251
1252       begin
1253          if Nkind (Pref) = N_Identifier then
1254             CE := Entity (Pref);
1255          else
1256             CE := Entity (Selector_Name (Pref));
1257          end if;
1258
1259          if Known_Static_Component_Bit_Offset (CE) then
1260             Rewrite (N,
1261               Make_Integer_Literal (Loc,
1262                 Intval => Component_Bit_Offset (CE)));
1263             Analyze_And_Resolve (N, Typ);
1264
1265          else
1266             Apply_Universal_Integer_Attribute_Checks (N);
1267          end if;
1268       end Bit_Position;
1269
1270       ------------------
1271       -- Body_Version --
1272       ------------------
1273
1274       --  A reference to P'Body_Version or P'Version is expanded to
1275
1276       --     Vnn : Unsigned;
1277       --     pragma Import (C, Vnn, "uuuuT");
1278       --     ...
1279       --     Get_Version_String (Vnn)
1280
1281       --  where uuuu is the unit name (dots replaced by double underscore)
1282       --  and T is B for the cases of Body_Version, or Version applied to a
1283       --  subprogram acting as its own spec, and S for Version applied to a
1284       --  subprogram spec or package. This sequence of code references the
1285       --  unsigned constant created in the main program by the binder.
1286
1287       --  A special exception occurs for Standard, where the string returned
1288       --  is a copy of the library string in gnatvsn.ads.
1289
1290       when Attribute_Body_Version | Attribute_Version => Version : declare
1291          E    : constant Entity_Id := Make_Temporary (Loc, 'V');
1292          Pent : Entity_Id;
1293          S    : String_Id;
1294
1295       begin
1296          --  If not library unit, get to containing library unit
1297
1298          Pent := Entity (Pref);
1299          while Pent /= Standard_Standard
1300            and then Scope (Pent) /= Standard_Standard
1301            and then not Is_Child_Unit (Pent)
1302          loop
1303             Pent := Scope (Pent);
1304          end loop;
1305
1306          --  Special case Standard and Standard.ASCII
1307
1308          if Pent = Standard_Standard or else Pent = Standard_ASCII then
1309             Rewrite (N,
1310               Make_String_Literal (Loc,
1311                 Strval => Verbose_Library_Version));
1312
1313          --  All other cases
1314
1315          else
1316             --  Build required string constant
1317
1318             Get_Name_String (Get_Unit_Name (Pent));
1319
1320             Start_String;
1321             for J in 1 .. Name_Len - 2 loop
1322                if Name_Buffer (J) = '.' then
1323                   Store_String_Chars ("__");
1324                else
1325                   Store_String_Char (Get_Char_Code (Name_Buffer (J)));
1326                end if;
1327             end loop;
1328
1329             --  Case of subprogram acting as its own spec, always use body
1330
1331             if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
1332               and then Nkind (Parent (Declaration_Node (Pent))) =
1333                                                           N_Subprogram_Body
1334               and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
1335             then
1336                Store_String_Chars ("B");
1337
1338             --  Case of no body present, always use spec
1339
1340             elsif not Unit_Requires_Body (Pent) then
1341                Store_String_Chars ("S");
1342
1343             --  Otherwise use B for Body_Version, S for spec
1344
1345             elsif Id = Attribute_Body_Version then
1346                Store_String_Chars ("B");
1347             else
1348                Store_String_Chars ("S");
1349             end if;
1350
1351             S := End_String;
1352             Lib.Version_Referenced (S);
1353
1354             --  Insert the object declaration
1355
1356             Insert_Actions (N, New_List (
1357               Make_Object_Declaration (Loc,
1358                 Defining_Identifier => E,
1359                 Object_Definition   =>
1360                   New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
1361
1362             --  Set entity as imported with correct external name
1363
1364             Set_Is_Imported (E);
1365             Set_Interface_Name (E, Make_String_Literal (Loc, S));
1366
1367             --  Set entity as internal to ensure proper Sprint output of its
1368             --  implicit importation.
1369
1370             Set_Is_Internal (E);
1371
1372             --  And now rewrite original reference
1373
1374             Rewrite (N,
1375               Make_Function_Call (Loc,
1376                 Name => New_Reference_To (RTE (RE_Get_Version_String), Loc),
1377                 Parameter_Associations => New_List (
1378                   New_Occurrence_Of (E, Loc))));
1379          end if;
1380
1381          Analyze_And_Resolve (N, RTE (RE_Version_String));
1382       end Version;
1383
1384       -------------
1385       -- Ceiling --
1386       -------------
1387
1388       --  Transforms 'Ceiling into a call to the floating-point attribute
1389       --  function Ceiling in Fat_xxx (where xxx is the root type)
1390
1391       when Attribute_Ceiling =>
1392          Expand_Fpt_Attribute_R (N);
1393
1394       --------------
1395       -- Callable --
1396       --------------
1397
1398       --  Transforms 'Callable attribute into a call to the Callable function
1399
1400       when Attribute_Callable => Callable :
1401       begin
1402          --  We have an object of a task interface class-wide type as a prefix
1403          --  to Callable. Generate:
1404          --    callable (Task_Id (Pref._disp_get_task_id));
1405
1406          if Ada_Version >= Ada_2005
1407            and then Ekind (Ptyp) = E_Class_Wide_Type
1408            and then Is_Interface (Ptyp)
1409            and then Is_Task_Interface (Ptyp)
1410          then
1411             Rewrite (N,
1412               Make_Function_Call (Loc,
1413                 Name =>
1414                   New_Reference_To (RTE (RE_Callable), Loc),
1415                 Parameter_Associations => New_List (
1416                   Make_Unchecked_Type_Conversion (Loc,
1417                     Subtype_Mark =>
1418                       New_Reference_To (RTE (RO_ST_Task_Id), Loc),
1419                     Expression =>
1420                       Make_Selected_Component (Loc,
1421                         Prefix =>
1422                           New_Copy_Tree (Pref),
1423                         Selector_Name =>
1424                           Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
1425
1426          else
1427             Rewrite (N,
1428               Build_Call_With_Task (Pref, RTE (RE_Callable)));
1429          end if;
1430
1431          Analyze_And_Resolve (N, Standard_Boolean);
1432       end Callable;
1433
1434       ------------
1435       -- Caller --
1436       ------------
1437
1438       --  Transforms 'Caller attribute into a call to either the
1439       --  Task_Entry_Caller or the Protected_Entry_Caller function.
1440
1441       when Attribute_Caller => Caller : declare
1442          Id_Kind    : constant Entity_Id := RTE (RO_AT_Task_Id);
1443          Ent        : constant Entity_Id := Entity (Pref);
1444          Conctype   : constant Entity_Id := Scope (Ent);
1445          Nest_Depth : Integer := 0;
1446          Name       : Node_Id;
1447          S          : Entity_Id;
1448
1449       begin
1450          --  Protected case
1451
1452          if Is_Protected_Type (Conctype) then
1453             case Corresponding_Runtime_Package (Conctype) is
1454                when System_Tasking_Protected_Objects_Entries =>
1455                   Name :=
1456                     New_Reference_To
1457                       (RTE (RE_Protected_Entry_Caller), Loc);
1458
1459                when System_Tasking_Protected_Objects_Single_Entry =>
1460                   Name :=
1461                     New_Reference_To
1462                       (RTE (RE_Protected_Single_Entry_Caller), Loc);
1463
1464                when others =>
1465                   raise Program_Error;
1466             end case;
1467
1468             Rewrite (N,
1469               Unchecked_Convert_To (Id_Kind,
1470                 Make_Function_Call (Loc,
1471                   Name => Name,
1472                   Parameter_Associations => New_List (
1473                     New_Reference_To
1474                       (Find_Protection_Object (Current_Scope), Loc)))));
1475
1476          --  Task case
1477
1478          else
1479             --  Determine the nesting depth of the E'Caller attribute, that
1480             --  is, how many accept statements are nested within the accept
1481             --  statement for E at the point of E'Caller. The runtime uses
1482             --  this depth to find the specified entry call.
1483
1484             for J in reverse 0 .. Scope_Stack.Last loop
1485                S := Scope_Stack.Table (J).Entity;
1486
1487                --  We should not reach the scope of the entry, as it should
1488                --  already have been checked in Sem_Attr that this attribute
1489                --  reference is within a matching accept statement.
1490
1491                pragma Assert (S /= Conctype);
1492
1493                if S = Ent then
1494                   exit;
1495
1496                elsif Is_Entry (S) then
1497                   Nest_Depth := Nest_Depth + 1;
1498                end if;
1499             end loop;
1500
1501             Rewrite (N,
1502               Unchecked_Convert_To (Id_Kind,
1503                 Make_Function_Call (Loc,
1504                   Name =>
1505                     New_Reference_To (RTE (RE_Task_Entry_Caller), Loc),
1506                   Parameter_Associations => New_List (
1507                     Make_Integer_Literal (Loc,
1508                       Intval => Int (Nest_Depth))))));
1509          end if;
1510
1511          Analyze_And_Resolve (N, Id_Kind);
1512       end Caller;
1513
1514       -------------
1515       -- Compose --
1516       -------------
1517
1518       --  Transforms 'Compose into a call to the floating-point attribute
1519       --  function Compose in Fat_xxx (where xxx is the root type)
1520
1521       --  Note: we strictly should have special code here to deal with the
1522       --  case of absurdly negative arguments (less than Integer'First)
1523       --  which will return a (signed) zero value, but it hardly seems
1524       --  worth the effort. Absurdly large positive arguments will raise
1525       --  constraint error which is fine.
1526
1527       when Attribute_Compose =>
1528          Expand_Fpt_Attribute_RI (N);
1529
1530       -----------------
1531       -- Constrained --
1532       -----------------
1533
1534       when Attribute_Constrained => Constrained : declare
1535          Formal_Ent : constant Entity_Id := Param_Entity (Pref);
1536
1537          function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean;
1538          --  Ada 2005 (AI-363): Returns True if the object name Obj denotes a
1539          --  view of an aliased object whose subtype is constrained.
1540
1541          ---------------------------------
1542          -- Is_Constrained_Aliased_View --
1543          ---------------------------------
1544
1545          function Is_Constrained_Aliased_View (Obj : Node_Id) return Boolean is
1546             E : Entity_Id;
1547
1548          begin
1549             if Is_Entity_Name (Obj) then
1550                E := Entity (Obj);
1551
1552                if Present (Renamed_Object (E)) then
1553                   return Is_Constrained_Aliased_View (Renamed_Object (E));
1554                else
1555                   return Is_Aliased (E) and then Is_Constrained (Etype (E));
1556                end if;
1557
1558             else
1559                return Is_Aliased_View (Obj)
1560                         and then
1561                       (Is_Constrained (Etype (Obj))
1562                          or else (Nkind (Obj) = N_Explicit_Dereference
1563                                     and then
1564                                       not Has_Constrained_Partial_View
1565                                             (Base_Type (Etype (Obj)))));
1566             end if;
1567          end Is_Constrained_Aliased_View;
1568
1569       --  Start of processing for Constrained
1570
1571       begin
1572          --  Reference to a parameter where the value is passed as an extra
1573          --  actual, corresponding to the extra formal referenced by the
1574          --  Extra_Constrained field of the corresponding formal. If this
1575          --  is an entry in-parameter, it is replaced by a constant renaming
1576          --  for which Extra_Constrained is never created.
1577
1578          if Present (Formal_Ent)
1579            and then Ekind (Formal_Ent) /= E_Constant
1580            and then Present (Extra_Constrained (Formal_Ent))
1581          then
1582             Rewrite (N,
1583               New_Occurrence_Of
1584                 (Extra_Constrained (Formal_Ent), Sloc (N)));
1585
1586          --  For variables with a Extra_Constrained field, we use the
1587          --  corresponding entity.
1588
1589          elsif Nkind (Pref) = N_Identifier
1590            and then Ekind (Entity (Pref)) = E_Variable
1591            and then Present (Extra_Constrained (Entity (Pref)))
1592          then
1593             Rewrite (N,
1594               New_Occurrence_Of
1595                 (Extra_Constrained (Entity (Pref)), Sloc (N)));
1596
1597          --  For all other entity names, we can tell at compile time
1598
1599          elsif Is_Entity_Name (Pref) then
1600             declare
1601                Ent : constant Entity_Id   := Entity (Pref);
1602                Res : Boolean;
1603
1604             begin
1605                --  (RM J.4) obsolescent cases
1606
1607                if Is_Type (Ent) then
1608
1609                   --  Private type
1610
1611                   if Is_Private_Type (Ent) then
1612                      Res := not Has_Discriminants (Ent)
1613                               or else Is_Constrained (Ent);
1614
1615                   --  It not a private type, must be a generic actual type
1616                   --  that corresponded to a private type. We know that this
1617                   --  correspondence holds, since otherwise the reference
1618                   --  within the generic template would have been illegal.
1619
1620                   else
1621                      if Is_Composite_Type (Underlying_Type (Ent)) then
1622                         Res := Is_Constrained (Ent);
1623                      else
1624                         Res := True;
1625                      end if;
1626                   end if;
1627
1628                --  If the prefix is not a variable or is aliased, then
1629                --  definitely true; if it's a formal parameter without an
1630                --  associated extra formal, then treat it as constrained.
1631
1632                --  Ada 2005 (AI-363): An aliased prefix must be known to be
1633                --  constrained in order to set the attribute to True.
1634
1635                elsif not Is_Variable (Pref)
1636                  or else Present (Formal_Ent)
1637                  or else (Ada_Version < Ada_2005
1638                             and then Is_Aliased_View (Pref))
1639                  or else (Ada_Version >= Ada_2005
1640                             and then Is_Constrained_Aliased_View (Pref))
1641                then
1642                   Res := True;
1643
1644                --  Variable case, look at type to see if it is constrained.
1645                --  Note that the one case where this is not accurate (the
1646                --  procedure formal case), has been handled above.
1647
1648                --  We use the Underlying_Type here (and below) in case the
1649                --  type is private without discriminants, but the full type
1650                --  has discriminants. This case is illegal, but we generate it
1651                --  internally for passing to the Extra_Constrained parameter.
1652
1653                else
1654                   --  In Ada 2012, test for case of a limited tagged type, in
1655                   --  which case the attribute is always required to return
1656                   --  True. The underlying type is tested, to make sure we also
1657                   --  return True for cases where there is an unconstrained
1658                   --  object with an untagged limited partial view which has
1659                   --  defaulted discriminants (such objects always produce a
1660                   --  False in earlier versions of Ada). (Ada 2012: AI05-0214)
1661
1662                   Res := Is_Constrained (Underlying_Type (Etype (Ent)))
1663                            or else
1664                              (Ada_Version >= Ada_2012
1665                                and then Is_Tagged_Type (Underlying_Type (Ptyp))
1666                                and then Is_Limited_Type (Ptyp));
1667                end if;
1668
1669                Rewrite (N, New_Reference_To (Boolean_Literals (Res), Loc));
1670             end;
1671
1672          --  Prefix is not an entity name. These are also cases where we can
1673          --  always tell at compile time by looking at the form and type of the
1674          --  prefix. If an explicit dereference of an object with constrained
1675          --  partial view, this is unconstrained (Ada 2005: AI95-0363). If the
1676          --  underlying type is a limited tagged type, then Constrained is
1677          --  required to always return True (Ada 2012: AI05-0214).
1678
1679          else
1680             Rewrite (N,
1681               New_Reference_To (
1682                 Boolean_Literals (
1683                   not Is_Variable (Pref)
1684                     or else
1685                      (Nkind (Pref) = N_Explicit_Dereference
1686                        and then
1687                          not Has_Constrained_Partial_View (Base_Type (Ptyp)))
1688                     or else Is_Constrained (Underlying_Type (Ptyp))
1689                     or else (Ada_Version >= Ada_2012
1690                               and then Is_Tagged_Type (Underlying_Type (Ptyp))
1691                               and then Is_Limited_Type (Ptyp))),
1692                 Loc));
1693          end if;
1694
1695          Analyze_And_Resolve (N, Standard_Boolean);
1696       end Constrained;
1697
1698       ---------------
1699       -- Copy_Sign --
1700       ---------------
1701
1702       --  Transforms 'Copy_Sign into a call to the floating-point attribute
1703       --  function Copy_Sign in Fat_xxx (where xxx is the root type)
1704
1705       when Attribute_Copy_Sign =>
1706          Expand_Fpt_Attribute_RR (N);
1707
1708       -----------
1709       -- Count --
1710       -----------
1711
1712       --  Transforms 'Count attribute into a call to the Count function
1713
1714       when Attribute_Count => Count : declare
1715          Call     : Node_Id;
1716          Conctyp  : Entity_Id;
1717          Entnam   : Node_Id;
1718          Entry_Id : Entity_Id;
1719          Index    : Node_Id;
1720          Name     : Node_Id;
1721
1722       begin
1723          --  If the prefix is a member of an entry family, retrieve both
1724          --  entry name and index. For a simple entry there is no index.
1725
1726          if Nkind (Pref) = N_Indexed_Component then
1727             Entnam := Prefix (Pref);
1728             Index := First (Expressions (Pref));
1729          else
1730             Entnam := Pref;
1731             Index := Empty;
1732          end if;
1733
1734          Entry_Id := Entity (Entnam);
1735
1736          --  Find the concurrent type in which this attribute is referenced
1737          --  (there had better be one).
1738
1739          Conctyp := Current_Scope;
1740          while not Is_Concurrent_Type (Conctyp) loop
1741             Conctyp := Scope (Conctyp);
1742          end loop;
1743
1744          --  Protected case
1745
1746          if Is_Protected_Type (Conctyp) then
1747             case Corresponding_Runtime_Package (Conctyp) is
1748                when System_Tasking_Protected_Objects_Entries =>
1749                   Name := New_Reference_To (RTE (RE_Protected_Count), Loc);
1750
1751                   Call :=
1752                     Make_Function_Call (Loc,
1753                       Name => Name,
1754                       Parameter_Associations => New_List (
1755                         New_Reference_To
1756                           (Find_Protection_Object (Current_Scope), Loc),
1757                         Entry_Index_Expression
1758                           (Loc, Entry_Id, Index, Scope (Entry_Id))));
1759
1760                when System_Tasking_Protected_Objects_Single_Entry =>
1761                   Name :=
1762                     New_Reference_To (RTE (RE_Protected_Count_Entry), Loc);
1763
1764                   Call :=
1765                     Make_Function_Call (Loc,
1766                       Name => Name,
1767                       Parameter_Associations => New_List (
1768                         New_Reference_To
1769                           (Find_Protection_Object (Current_Scope), Loc)));
1770
1771                when others =>
1772                   raise Program_Error;
1773             end case;
1774
1775          --  Task case
1776
1777          else
1778             Call :=
1779               Make_Function_Call (Loc,
1780                 Name => New_Reference_To (RTE (RE_Task_Count), Loc),
1781                 Parameter_Associations => New_List (
1782                   Entry_Index_Expression (Loc,
1783                     Entry_Id, Index, Scope (Entry_Id))));
1784          end if;
1785
1786          --  The call returns type Natural but the context is universal integer
1787          --  so any integer type is allowed. The attribute was already resolved
1788          --  so its Etype is the required result type. If the base type of the
1789          --  context type is other than Standard.Integer we put in a conversion
1790          --  to the required type. This can be a normal typed conversion since
1791          --  both input and output types of the conversion are integer types
1792
1793          if Base_Type (Typ) /= Base_Type (Standard_Integer) then
1794             Rewrite (N, Convert_To (Typ, Call));
1795          else
1796             Rewrite (N, Call);
1797          end if;
1798
1799          Analyze_And_Resolve (N, Typ);
1800       end Count;
1801
1802       ---------------
1803       -- Elab_Body --
1804       ---------------
1805
1806       --  This processing is shared by Elab_Spec
1807
1808       --  What we do is to insert the following declarations
1809
1810       --     procedure tnn;
1811       --     pragma Import (C, enn, "name___elabb/s");
1812
1813       --  and then the Elab_Body/Spec attribute is replaced by a reference
1814       --  to this defining identifier.
1815
1816       when Attribute_Elab_Body |
1817            Attribute_Elab_Spec =>
1818
1819          --  Leave attribute unexpanded in CodePeer mode: the gnat2scil
1820          --  back-end knows how to handle this attribute directly.
1821
1822          if CodePeer_Mode then
1823             return;
1824          end if;
1825
1826          Elab_Body : declare
1827             Ent  : constant Entity_Id := Make_Temporary (Loc, 'E');
1828             Str  : String_Id;
1829             Lang : Node_Id;
1830
1831             procedure Make_Elab_String (Nod : Node_Id);
1832             --  Given Nod, an identifier, or a selected component, put the
1833             --  image into the current string literal, with double underline
1834             --  between components.
1835
1836             ----------------------
1837             -- Make_Elab_String --
1838             ----------------------
1839
1840             procedure Make_Elab_String (Nod : Node_Id) is
1841             begin
1842                if Nkind (Nod) = N_Selected_Component then
1843                   Make_Elab_String (Prefix (Nod));
1844
1845                   case VM_Target is
1846                      when JVM_Target =>
1847                         Store_String_Char ('$');
1848                      when CLI_Target =>
1849                         Store_String_Char ('.');
1850                      when No_VM =>
1851                         Store_String_Char ('_');
1852                         Store_String_Char ('_');
1853                   end case;
1854
1855                   Get_Name_String (Chars (Selector_Name (Nod)));
1856
1857                else
1858                   pragma Assert (Nkind (Nod) = N_Identifier);
1859                   Get_Name_String (Chars (Nod));
1860                end if;
1861
1862                Store_String_Chars (Name_Buffer (1 .. Name_Len));
1863             end Make_Elab_String;
1864
1865          --  Start of processing for Elab_Body/Elab_Spec
1866
1867          begin
1868             --  First we need to prepare the string literal for the name of
1869             --  the elaboration routine to be referenced.
1870
1871             Start_String;
1872             Make_Elab_String (Pref);
1873
1874             if VM_Target = No_VM then
1875                Store_String_Chars ("___elab");
1876                Lang := Make_Identifier (Loc, Name_C);
1877             else
1878                Store_String_Chars ("._elab");
1879                Lang := Make_Identifier (Loc, Name_Ada);
1880             end if;
1881
1882             if Id = Attribute_Elab_Body then
1883                Store_String_Char ('b');
1884             else
1885                Store_String_Char ('s');
1886             end if;
1887
1888             Str := End_String;
1889
1890             Insert_Actions (N, New_List (
1891               Make_Subprogram_Declaration (Loc,
1892                 Specification =>
1893                   Make_Procedure_Specification (Loc,
1894                     Defining_Unit_Name => Ent)),
1895
1896               Make_Pragma (Loc,
1897                 Chars => Name_Import,
1898                 Pragma_Argument_Associations => New_List (
1899                   Make_Pragma_Argument_Association (Loc, Expression => Lang),
1900
1901                   Make_Pragma_Argument_Association (Loc,
1902                     Expression => Make_Identifier (Loc, Chars (Ent))),
1903
1904                   Make_Pragma_Argument_Association (Loc,
1905                     Expression => Make_String_Literal (Loc, Str))))));
1906
1907             Set_Entity (N, Ent);
1908             Rewrite (N, New_Occurrence_Of (Ent, Loc));
1909          end Elab_Body;
1910
1911       ----------------
1912       -- Elaborated --
1913       ----------------
1914
1915       --  Elaborated is always True for preelaborated units, predefined units,
1916       --  pure units and units which have Elaborate_Body pragmas. These units
1917       --  have no elaboration entity.
1918
1919       --  Note: The Elaborated attribute is never passed to the back end
1920
1921       when Attribute_Elaborated => Elaborated : declare
1922          Ent : constant Entity_Id := Entity (Pref);
1923
1924       begin
1925          if Present (Elaboration_Entity (Ent)) then
1926             Rewrite (N,
1927               Make_Op_Ne (Loc,
1928                 Left_Opnd =>
1929                   New_Occurrence_Of (Elaboration_Entity (Ent), Loc),
1930                 Right_Opnd =>
1931                   Make_Integer_Literal (Loc, Uint_0)));
1932             Analyze_And_Resolve (N, Typ);
1933          else
1934             Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
1935          end if;
1936       end Elaborated;
1937
1938       --------------
1939       -- Enum_Rep --
1940       --------------
1941
1942       when Attribute_Enum_Rep => Enum_Rep :
1943       begin
1944          --  X'Enum_Rep (Y) expands to
1945
1946          --    target-type (Y)
1947
1948          --  This is simply a direct conversion from the enumeration type to
1949          --  the target integer type, which is treated by the back end as a
1950          --  normal integer conversion, treating the enumeration type as an
1951          --  integer, which is exactly what we want! We set Conversion_OK to
1952          --  make sure that the analyzer does not complain about what otherwise
1953          --  might be an illegal conversion.
1954
1955          if Is_Non_Empty_List (Exprs) then
1956             Rewrite (N,
1957               OK_Convert_To (Typ, Relocate_Node (First (Exprs))));
1958
1959          --  X'Enum_Rep where X is an enumeration literal is replaced by
1960          --  the literal value.
1961
1962          elsif Ekind (Entity (Pref)) = E_Enumeration_Literal then
1963             Rewrite (N,
1964               Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref))));
1965
1966          --  If this is a renaming of a literal, recover the representation
1967          --  of the original.
1968
1969          elsif Ekind (Entity (Pref)) = E_Constant
1970            and then Present (Renamed_Object (Entity (Pref)))
1971            and then
1972              Ekind (Entity (Renamed_Object (Entity (Pref))))
1973                = E_Enumeration_Literal
1974          then
1975             Rewrite (N,
1976               Make_Integer_Literal (Loc,
1977                 Enumeration_Rep (Entity (Renamed_Object (Entity (Pref))))));
1978
1979          --  X'Enum_Rep where X is an object does a direct unchecked conversion
1980          --  of the object value, as described for the type case above.
1981
1982          else
1983             Rewrite (N,
1984               OK_Convert_To (Typ, Relocate_Node (Pref)));
1985          end if;
1986
1987          Set_Etype (N, Typ);
1988          Analyze_And_Resolve (N, Typ);
1989       end Enum_Rep;
1990
1991       --------------
1992       -- Enum_Val --
1993       --------------
1994
1995       when Attribute_Enum_Val => Enum_Val : declare
1996          Expr : Node_Id;
1997          Btyp : constant Entity_Id  := Base_Type (Ptyp);
1998
1999       begin
2000          --  X'Enum_Val (Y) expands to
2001
2002          --    [constraint_error when _rep_to_pos (Y, False) = -1, msg]
2003          --    X!(Y);
2004
2005          Expr := Unchecked_Convert_To (Ptyp, First (Exprs));
2006
2007          Insert_Action (N,
2008            Make_Raise_Constraint_Error (Loc,
2009              Condition =>
2010                Make_Op_Eq (Loc,
2011                  Left_Opnd =>
2012                    Make_Function_Call (Loc,
2013                      Name =>
2014                        New_Reference_To (TSS (Btyp, TSS_Rep_To_Pos), Loc),
2015                      Parameter_Associations => New_List (
2016                        Relocate_Node (Duplicate_Subexpr (Expr)),
2017                          New_Occurrence_Of (Standard_False, Loc))),
2018
2019                  Right_Opnd => Make_Integer_Literal (Loc, -1)),
2020              Reason => CE_Range_Check_Failed));
2021
2022          Rewrite (N, Expr);
2023          Analyze_And_Resolve (N, Ptyp);
2024       end Enum_Val;
2025
2026       --------------
2027       -- Exponent --
2028       --------------
2029
2030       --  Transforms 'Exponent into a call to the floating-point attribute
2031       --  function Exponent in Fat_xxx (where xxx is the root type)
2032
2033       when Attribute_Exponent =>
2034          Expand_Fpt_Attribute_R (N);
2035
2036       ------------------
2037       -- External_Tag --
2038       ------------------
2039
2040       --  transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
2041
2042       when Attribute_External_Tag => External_Tag :
2043       begin
2044          Rewrite (N,
2045            Make_Function_Call (Loc,
2046              Name => New_Reference_To (RTE (RE_External_Tag), Loc),
2047              Parameter_Associations => New_List (
2048                Make_Attribute_Reference (Loc,
2049                  Attribute_Name => Name_Tag,
2050                  Prefix => Prefix (N)))));
2051
2052          Analyze_And_Resolve (N, Standard_String);
2053       end External_Tag;
2054
2055       -----------
2056       -- First --
2057       -----------
2058
2059       when Attribute_First =>
2060
2061          --  If the prefix type is a constrained packed array type which
2062          --  already has a Packed_Array_Type representation defined, then
2063          --  replace this attribute with a direct reference to 'First of the
2064          --  appropriate index subtype (since otherwise the back end will try
2065          --  to give us the value of 'First for this implementation type).
2066
2067          if Is_Constrained_Packed_Array (Ptyp) then
2068             Rewrite (N,
2069               Make_Attribute_Reference (Loc,
2070                 Attribute_Name => Name_First,
2071                 Prefix => New_Reference_To (Get_Index_Subtype (N), Loc)));
2072             Analyze_And_Resolve (N, Typ);
2073
2074          elsif Is_Access_Type (Ptyp) then
2075             Apply_Access_Check (N);
2076          end if;
2077
2078       ---------------
2079       -- First_Bit --
2080       ---------------
2081
2082       --  Compute this if component clause was present, otherwise we leave the
2083       --  computation to be completed in the back-end, since we don't know what
2084       --  layout will be chosen.
2085
2086       when Attribute_First_Bit => First_Bit : declare
2087          CE : constant Entity_Id := Entity (Selector_Name (Pref));
2088
2089       begin
2090          if Known_Static_Component_Bit_Offset (CE) then
2091             Rewrite (N,
2092               Make_Integer_Literal (Loc,
2093                 Component_Bit_Offset (CE) mod System_Storage_Unit));
2094
2095             Analyze_And_Resolve (N, Typ);
2096
2097          else
2098             Apply_Universal_Integer_Attribute_Checks (N);
2099          end if;
2100       end First_Bit;
2101
2102       -----------------
2103       -- Fixed_Value --
2104       -----------------
2105
2106       --  We transform:
2107
2108       --     fixtype'Fixed_Value (integer-value)
2109
2110       --  into
2111
2112       --     fixtype(integer-value)
2113
2114       --  We do all the required analysis of the conversion here, because we do
2115       --  not want this to go through the fixed-point conversion circuits. Note
2116       --  that the back end always treats fixed-point as equivalent to the
2117       --  corresponding integer type anyway.
2118
2119       when Attribute_Fixed_Value => Fixed_Value :
2120       begin
2121          Rewrite (N,
2122            Make_Type_Conversion (Loc,
2123              Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
2124              Expression   => Relocate_Node (First (Exprs))));
2125          Set_Etype (N, Entity (Pref));
2126          Set_Analyzed (N);
2127
2128       --  Note: it might appear that a properly analyzed unchecked conversion
2129       --  would be just fine here, but that's not the case, since the full
2130       --  range checks performed by the following call are critical!
2131
2132          Apply_Type_Conversion_Checks (N);
2133       end Fixed_Value;
2134
2135       -----------
2136       -- Floor --
2137       -----------
2138
2139       --  Transforms 'Floor into a call to the floating-point attribute
2140       --  function Floor in Fat_xxx (where xxx is the root type)
2141
2142       when Attribute_Floor =>
2143          Expand_Fpt_Attribute_R (N);
2144
2145       ----------
2146       -- Fore --
2147       ----------
2148
2149       --  For the fixed-point type Typ:
2150
2151       --    Typ'Fore
2152
2153       --  expands into
2154
2155       --    Result_Type (System.Fore (Universal_Real (Type'First)),
2156       --                              Universal_Real (Type'Last))
2157
2158       --  Note that we know that the type is a non-static subtype, or Fore
2159       --  would have itself been computed dynamically in Eval_Attribute.
2160
2161       when Attribute_Fore => Fore : begin
2162          Rewrite (N,
2163            Convert_To (Typ,
2164              Make_Function_Call (Loc,
2165                Name => New_Reference_To (RTE (RE_Fore), Loc),
2166
2167                Parameter_Associations => New_List (
2168                  Convert_To (Universal_Real,
2169                    Make_Attribute_Reference (Loc,
2170                      Prefix => New_Reference_To (Ptyp, Loc),
2171                      Attribute_Name => Name_First)),
2172
2173                  Convert_To (Universal_Real,
2174                    Make_Attribute_Reference (Loc,
2175                      Prefix => New_Reference_To (Ptyp, Loc),
2176                      Attribute_Name => Name_Last))))));
2177
2178          Analyze_And_Resolve (N, Typ);
2179       end Fore;
2180
2181       --------------
2182       -- Fraction --
2183       --------------
2184
2185       --  Transforms 'Fraction into a call to the floating-point attribute
2186       --  function Fraction in Fat_xxx (where xxx is the root type)
2187
2188       when Attribute_Fraction =>
2189          Expand_Fpt_Attribute_R (N);
2190
2191       --------------
2192       -- From_Any --
2193       --------------
2194
2195       when Attribute_From_Any => From_Any : declare
2196          P_Type : constant Entity_Id := Etype (Pref);
2197          Decls  : constant List_Id   := New_List;
2198       begin
2199          Rewrite (N,
2200            Build_From_Any_Call (P_Type,
2201              Relocate_Node (First (Exprs)),
2202              Decls));
2203          Insert_Actions (N, Decls);
2204          Analyze_And_Resolve (N, P_Type);
2205       end From_Any;
2206
2207       --------------
2208       -- Identity --
2209       --------------
2210
2211       --  For an exception returns a reference to the exception data:
2212       --      Exception_Id!(Prefix'Reference)
2213
2214       --  For a task it returns a reference to the _task_id component of
2215       --  corresponding record:
2216
2217       --    taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
2218
2219       --  in Ada.Task_Identification
2220
2221       when Attribute_Identity => Identity : declare
2222          Id_Kind : Entity_Id;
2223
2224       begin
2225          if Ptyp = Standard_Exception_Type then
2226             Id_Kind := RTE (RE_Exception_Id);
2227
2228             if Present (Renamed_Object (Entity (Pref))) then
2229                Set_Entity (Pref, Renamed_Object (Entity (Pref)));
2230             end if;
2231
2232             Rewrite (N,
2233               Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref)));
2234          else
2235             Id_Kind := RTE (RO_AT_Task_Id);
2236
2237             --  If the prefix is a task interface, the Task_Id is obtained
2238             --  dynamically through a dispatching call, as for other task
2239             --  attributes applied to interfaces.
2240
2241             if Ada_Version >= Ada_2005
2242               and then Ekind (Ptyp) = E_Class_Wide_Type
2243               and then Is_Interface (Ptyp)
2244               and then Is_Task_Interface (Ptyp)
2245             then
2246                Rewrite (N,
2247                  Unchecked_Convert_To (Id_Kind,
2248                    Make_Selected_Component (Loc,
2249                      Prefix =>
2250                        New_Copy_Tree (Pref),
2251                      Selector_Name =>
2252                        Make_Identifier (Loc, Name_uDisp_Get_Task_Id))));
2253
2254             else
2255                Rewrite (N,
2256                  Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
2257             end if;
2258          end if;
2259
2260          Analyze_And_Resolve (N, Id_Kind);
2261       end Identity;
2262
2263       -----------
2264       -- Image --
2265       -----------
2266
2267       --  Image attribute is handled in separate unit Exp_Imgv
2268
2269       when Attribute_Image =>
2270          Exp_Imgv.Expand_Image_Attribute (N);
2271
2272       ---------
2273       -- Img --
2274       ---------
2275
2276       --  X'Img is expanded to typ'Image (X), where typ is the type of X
2277
2278       when Attribute_Img => Img :
2279       begin
2280          Rewrite (N,
2281            Make_Attribute_Reference (Loc,
2282              Prefix => New_Reference_To (Ptyp, Loc),
2283              Attribute_Name => Name_Image,
2284              Expressions => New_List (Relocate_Node (Pref))));
2285
2286          Analyze_And_Resolve (N, Standard_String);
2287       end Img;
2288
2289       -----------
2290       -- Input --
2291       -----------
2292
2293       when Attribute_Input => Input : declare
2294          P_Type : constant Entity_Id := Entity (Pref);
2295          B_Type : constant Entity_Id := Base_Type (P_Type);
2296          U_Type : constant Entity_Id := Underlying_Type (P_Type);
2297          Strm   : constant Node_Id   := First (Exprs);
2298          Fname  : Entity_Id;
2299          Decl   : Node_Id;
2300          Call   : Node_Id;
2301          Prag   : Node_Id;
2302          Arg2   : Node_Id;
2303          Rfunc  : Node_Id;
2304
2305          Cntrl  : Node_Id := Empty;
2306          --  Value for controlling argument in call. Always Empty except in
2307          --  the dispatching (class-wide type) case, where it is a reference
2308          --  to the dummy object initialized to the right internal tag.
2309
2310          procedure Freeze_Stream_Subprogram (F : Entity_Id);
2311          --  The expansion of the attribute reference may generate a call to
2312          --  a user-defined stream subprogram that is frozen by the call. This
2313          --  can lead to access-before-elaboration problem if the reference
2314          --  appears in an object declaration and the subprogram body has not
2315          --  been seen. The freezing of the subprogram requires special code
2316          --  because it appears in an expanded context where expressions do
2317          --  not freeze their constituents.
2318
2319          ------------------------------
2320          -- Freeze_Stream_Subprogram --
2321          ------------------------------
2322
2323          procedure Freeze_Stream_Subprogram (F : Entity_Id) is
2324             Decl : constant Node_Id := Unit_Declaration_Node (F);
2325             Bod  : Node_Id;
2326
2327          begin
2328             --  If this is user-defined subprogram, the corresponding
2329             --  stream function appears as a renaming-as-body, and the
2330             --  user subprogram must be retrieved by tree traversal.
2331
2332             if Present (Decl)
2333               and then Nkind (Decl) = N_Subprogram_Declaration
2334               and then Present (Corresponding_Body (Decl))
2335             then
2336                Bod := Corresponding_Body (Decl);
2337
2338                if Nkind (Unit_Declaration_Node (Bod)) =
2339                  N_Subprogram_Renaming_Declaration
2340                then
2341                   Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod))));
2342                end if;
2343             end if;
2344          end Freeze_Stream_Subprogram;
2345
2346       --  Start of processing for Input
2347
2348       begin
2349          --  If no underlying type, we have an error that will be diagnosed
2350          --  elsewhere, so here we just completely ignore the expansion.
2351
2352          if No (U_Type) then
2353             return;
2354          end if;
2355
2356          --  If there is a TSS for Input, just call it
2357
2358          Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
2359
2360          if Present (Fname) then
2361             null;
2362
2363          else
2364             --  If there is a Stream_Convert pragma, use it, we rewrite
2365
2366             --     sourcetyp'Input (stream)
2367
2368             --  as
2369
2370             --     sourcetyp (streamread (strmtyp'Input (stream)));
2371
2372             --  where streamread is the given Read function that converts an
2373             --  argument of type strmtyp to type sourcetyp or a type from which
2374             --  it is derived (extra conversion required for the derived case).
2375
2376             Prag := Get_Stream_Convert_Pragma (P_Type);
2377
2378             if Present (Prag) then
2379                Arg2  := Next (First (Pragma_Argument_Associations (Prag)));
2380                Rfunc := Entity (Expression (Arg2));
2381
2382                Rewrite (N,
2383                  Convert_To (B_Type,
2384                    Make_Function_Call (Loc,
2385                      Name => New_Occurrence_Of (Rfunc, Loc),
2386                      Parameter_Associations => New_List (
2387                        Make_Attribute_Reference (Loc,
2388                          Prefix =>
2389                            New_Occurrence_Of
2390                              (Etype (First_Formal (Rfunc)), Loc),
2391                          Attribute_Name => Name_Input,
2392                          Expressions => Exprs)))));
2393
2394                Analyze_And_Resolve (N, B_Type);
2395                return;
2396
2397             --  Elementary types
2398
2399             elsif Is_Elementary_Type (U_Type) then
2400
2401                --  A special case arises if we have a defined _Read routine,
2402                --  since in this case we are required to call this routine.
2403
2404                if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then
2405                   Build_Record_Or_Elementary_Input_Function
2406                     (Loc, U_Type, Decl, Fname);
2407                   Insert_Action (N, Decl);
2408
2409                --  For normal cases, we call the I_xxx routine directly
2410
2411                else
2412                   Rewrite (N, Build_Elementary_Input_Call (N));
2413                   Analyze_And_Resolve (N, P_Type);
2414                   return;
2415                end if;
2416
2417             --  Array type case
2418
2419             elsif Is_Array_Type (U_Type) then
2420                Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
2421                Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
2422
2423             --  Dispatching case with class-wide type
2424
2425             elsif Is_Class_Wide_Type (P_Type) then
2426
2427                --  No need to do anything else compiling under restriction
2428                --  No_Dispatching_Calls. During the semantic analysis we
2429                --  already notified such violation.
2430
2431                if Restriction_Active (No_Dispatching_Calls) then
2432                   return;
2433                end if;
2434
2435                declare
2436                   Rtyp : constant Entity_Id := Root_Type (P_Type);
2437                   Dnn  : Entity_Id;
2438                   Decl : Node_Id;
2439                   Expr : Node_Id;
2440
2441                begin
2442                   --  Read the internal tag (RM 13.13.2(34)) and use it to
2443                   --  initialize a dummy tag object:
2444
2445                   --    Dnn : Ada.Tags.Tag :=
2446                   --            Descendant_Tag (String'Input (Strm), P_Type);
2447
2448                   --  This dummy object is used only to provide a controlling
2449                   --  argument for the eventual _Input call. Descendant_Tag is
2450                   --  called rather than Internal_Tag to ensure that we have a
2451                   --  tag for a type that is descended from the prefix type and
2452                   --  declared at the same accessibility level (the exception
2453                   --  Tag_Error will be raised otherwise). The level check is
2454                   --  required for Ada 2005 because tagged types can be
2455                   --  extended in nested scopes (AI-344).
2456
2457                   Expr :=
2458                     Make_Function_Call (Loc,
2459                       Name =>
2460                         New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
2461                       Parameter_Associations => New_List (
2462                         Make_Attribute_Reference (Loc,
2463                           Prefix => New_Occurrence_Of (Standard_String, Loc),
2464                           Attribute_Name => Name_Input,
2465                           Expressions => New_List (
2466                             Relocate_Node (Duplicate_Subexpr (Strm)))),
2467                         Make_Attribute_Reference (Loc,
2468                           Prefix => New_Reference_To (P_Type, Loc),
2469                           Attribute_Name => Name_Tag)));
2470
2471                   Dnn := Make_Temporary (Loc, 'D', Expr);
2472
2473                   Decl :=
2474                     Make_Object_Declaration (Loc,
2475                       Defining_Identifier => Dnn,
2476                       Object_Definition   =>
2477                         New_Occurrence_Of (RTE (RE_Tag), Loc),
2478                       Expression          => Expr);
2479
2480                   Insert_Action (N, Decl);
2481
2482                   --  Now we need to get the entity for the call, and construct
2483                   --  a function call node, where we preset a reference to Dnn
2484                   --  as the controlling argument (doing an unchecked convert
2485                   --  to the class-wide tagged type to make it look like a real
2486                   --  tagged object).
2487
2488                   Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
2489                   Cntrl :=
2490                     Unchecked_Convert_To (P_Type,
2491                       New_Occurrence_Of (Dnn, Loc));
2492                   Set_Etype (Cntrl, P_Type);
2493                   Set_Parent (Cntrl, N);
2494                end;
2495
2496             --  For tagged types, use the primitive Input function
2497
2498             elsif Is_Tagged_Type (U_Type) then
2499                Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
2500
2501             --  All other record type cases, including protected records. The
2502             --  latter only arise for expander generated code for handling
2503             --  shared passive partition access.
2504
2505             else
2506                pragma Assert
2507                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
2508
2509                --  Ada 2005 (AI-216): Program_Error is raised executing default
2510                --  implementation of the Input attribute of an unchecked union
2511                --  type if the type lacks default discriminant values.
2512
2513                if Is_Unchecked_Union (Base_Type (U_Type))
2514                  and then No (Discriminant_Constraint (U_Type))
2515                then
2516                   Insert_Action (N,
2517                     Make_Raise_Program_Error (Loc,
2518                       Reason => PE_Unchecked_Union_Restriction));
2519
2520                   return;
2521                end if;
2522
2523                Build_Record_Or_Elementary_Input_Function
2524                  (Loc, Base_Type (U_Type), Decl, Fname);
2525                Insert_Action (N, Decl);
2526
2527                if Nkind (Parent (N)) = N_Object_Declaration
2528                  and then Is_Record_Type (U_Type)
2529                then
2530                   --  The stream function may contain calls to user-defined
2531                   --  Read procedures for individual components.
2532
2533                   declare
2534                      Comp : Entity_Id;
2535                      Func : Entity_Id;
2536
2537                   begin
2538                      Comp := First_Component (U_Type);
2539                      while Present (Comp) loop
2540                         Func :=
2541                           Find_Stream_Subprogram
2542                             (Etype (Comp), TSS_Stream_Read);
2543
2544                         if Present (Func) then
2545                            Freeze_Stream_Subprogram (Func);
2546                         end if;
2547
2548                         Next_Component (Comp);
2549                      end loop;
2550                   end;
2551                end if;
2552             end if;
2553          end if;
2554
2555          --  If we fall through, Fname is the function to be called. The result
2556          --  is obtained by calling the appropriate function, then converting
2557          --  the result. The conversion does a subtype check.
2558
2559          Call :=
2560            Make_Function_Call (Loc,
2561              Name => New_Occurrence_Of (Fname, Loc),
2562              Parameter_Associations => New_List (
2563                 Relocate_Node (Strm)));
2564
2565          Set_Controlling_Argument (Call, Cntrl);
2566          Rewrite (N, Unchecked_Convert_To (P_Type, Call));
2567          Analyze_And_Resolve (N, P_Type);
2568
2569          if Nkind (Parent (N)) = N_Object_Declaration then
2570             Freeze_Stream_Subprogram (Fname);
2571          end if;
2572       end Input;
2573
2574       -------------------
2575       -- Integer_Value --
2576       -------------------
2577
2578       --  We transform
2579
2580       --    inttype'Fixed_Value (fixed-value)
2581
2582       --  into
2583
2584       --    inttype(integer-value))
2585
2586       --  we do all the required analysis of the conversion here, because we do
2587       --  not want this to go through the fixed-point conversion circuits. Note
2588       --  that the back end always treats fixed-point as equivalent to the
2589       --  corresponding integer type anyway.
2590
2591       when Attribute_Integer_Value => Integer_Value :
2592       begin
2593          Rewrite (N,
2594            Make_Type_Conversion (Loc,
2595              Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
2596              Expression   => Relocate_Node (First (Exprs))));
2597          Set_Etype (N, Entity (Pref));
2598          Set_Analyzed (N);
2599
2600       --  Note: it might appear that a properly analyzed unchecked conversion
2601       --  would be just fine here, but that's not the case, since the full
2602       --  range checks performed by the following call are critical!
2603
2604          Apply_Type_Conversion_Checks (N);
2605       end Integer_Value;
2606
2607       -------------------
2608       -- Invalid_Value --
2609       -------------------
2610
2611       when Attribute_Invalid_Value =>
2612          Rewrite (N, Get_Simple_Init_Val (Ptyp, N));
2613
2614       ----------
2615       -- Last --
2616       ----------
2617
2618       when Attribute_Last =>
2619
2620          --  If the prefix type is a constrained packed array type which
2621          --  already has a Packed_Array_Type representation defined, then
2622          --  replace this attribute with a direct reference to 'Last of the
2623          --  appropriate index subtype (since otherwise the back end will try
2624          --  to give us the value of 'Last for this implementation type).
2625
2626          if Is_Constrained_Packed_Array (Ptyp) then
2627             Rewrite (N,
2628               Make_Attribute_Reference (Loc,
2629                 Attribute_Name => Name_Last,
2630                 Prefix => New_Reference_To (Get_Index_Subtype (N), Loc)));
2631             Analyze_And_Resolve (N, Typ);
2632
2633          elsif Is_Access_Type (Ptyp) then
2634             Apply_Access_Check (N);
2635          end if;
2636
2637       --------------
2638       -- Last_Bit --
2639       --------------
2640
2641       --  We compute this if a component clause was present, otherwise we leave
2642       --  the computation up to the back end, since we don't know what layout
2643       --  will be chosen.
2644
2645       when Attribute_Last_Bit => Last_Bit : declare
2646          CE : constant Entity_Id := Entity (Selector_Name (Pref));
2647
2648       begin
2649          if Known_Static_Component_Bit_Offset (CE)
2650            and then Known_Static_Esize (CE)
2651          then
2652             Rewrite (N,
2653               Make_Integer_Literal (Loc,
2654                Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
2655                                 + Esize (CE) - 1));
2656
2657             Analyze_And_Resolve (N, Typ);
2658
2659          else
2660             Apply_Universal_Integer_Attribute_Checks (N);
2661          end if;
2662       end Last_Bit;
2663
2664       ------------------
2665       -- Leading_Part --
2666       ------------------
2667
2668       --  Transforms 'Leading_Part into a call to the floating-point attribute
2669       --  function Leading_Part in Fat_xxx (where xxx is the root type)
2670
2671       --  Note: strictly, we should generate special case code to deal with
2672       --  absurdly large positive arguments (greater than Integer'Last), which
2673       --  result in returning the first argument unchanged, but it hardly seems
2674       --  worth the effort. We raise constraint error for absurdly negative
2675       --  arguments which is fine.
2676
2677       when Attribute_Leading_Part =>
2678          Expand_Fpt_Attribute_RI (N);
2679
2680       ------------
2681       -- Length --
2682       ------------
2683
2684       when Attribute_Length => declare
2685          Ityp : Entity_Id;
2686          Xnum : Uint;
2687
2688       begin
2689          --  Processing for packed array types
2690
2691          if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
2692             Ityp := Get_Index_Subtype (N);
2693
2694             --  If the index type, Ityp, is an enumeration type with holes,
2695             --  then we calculate X'Length explicitly using
2696
2697             --     Typ'Max
2698             --       (0, Ityp'Pos (X'Last  (N)) -
2699             --           Ityp'Pos (X'First (N)) + 1);
2700
2701             --  Since the bounds in the template are the representation values
2702             --  and the back end would get the wrong value.
2703
2704             if Is_Enumeration_Type (Ityp)
2705               and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
2706             then
2707                if No (Exprs) then
2708                   Xnum := Uint_1;
2709                else
2710                   Xnum := Expr_Value (First (Expressions (N)));
2711                end if;
2712
2713                Rewrite (N,
2714                  Make_Attribute_Reference (Loc,
2715                    Prefix         => New_Occurrence_Of (Typ, Loc),
2716                    Attribute_Name => Name_Max,
2717                    Expressions    => New_List
2718                      (Make_Integer_Literal (Loc, 0),
2719
2720                       Make_Op_Add (Loc,
2721                         Left_Opnd =>
2722                           Make_Op_Subtract (Loc,
2723                             Left_Opnd =>
2724                               Make_Attribute_Reference (Loc,
2725                                 Prefix => New_Occurrence_Of (Ityp, Loc),
2726                                 Attribute_Name => Name_Pos,
2727
2728                                 Expressions => New_List (
2729                                   Make_Attribute_Reference (Loc,
2730                                     Prefix => Duplicate_Subexpr (Pref),
2731                                    Attribute_Name => Name_Last,
2732                                     Expressions => New_List (
2733                                       Make_Integer_Literal (Loc, Xnum))))),
2734
2735                             Right_Opnd =>
2736                               Make_Attribute_Reference (Loc,
2737                                 Prefix => New_Occurrence_Of (Ityp, Loc),
2738                                 Attribute_Name => Name_Pos,
2739
2740                                 Expressions => New_List (
2741                                   Make_Attribute_Reference (Loc,
2742                                     Prefix =>
2743                                       Duplicate_Subexpr_No_Checks (Pref),
2744                                    Attribute_Name => Name_First,
2745                                     Expressions => New_List (
2746                                       Make_Integer_Literal (Loc, Xnum)))))),
2747
2748                         Right_Opnd => Make_Integer_Literal (Loc, 1)))));
2749
2750                Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
2751                return;
2752
2753             --  If the prefix type is a constrained packed array type which
2754             --  already has a Packed_Array_Type representation defined, then
2755             --  replace this attribute with a direct reference to 'Range_Length
2756             --  of the appropriate index subtype (since otherwise the back end
2757             --  will try to give us the value of 'Length for this
2758             --  implementation type).
2759
2760             elsif Is_Constrained (Ptyp) then
2761                Rewrite (N,
2762                  Make_Attribute_Reference (Loc,
2763                    Attribute_Name => Name_Range_Length,
2764                    Prefix => New_Reference_To (Ityp, Loc)));
2765                Analyze_And_Resolve (N, Typ);
2766             end if;
2767
2768          --  Access type case
2769
2770          elsif Is_Access_Type (Ptyp) then
2771             Apply_Access_Check (N);
2772
2773             --  If the designated type is a packed array type, then we convert
2774             --  the reference to:
2775
2776             --    typ'Max (0, 1 +
2777             --                xtyp'Pos (Pref'Last (Expr)) -
2778             --                xtyp'Pos (Pref'First (Expr)));
2779
2780             --  This is a bit complex, but it is the easiest thing to do that
2781             --  works in all cases including enum types with holes xtyp here
2782             --  is the appropriate index type.
2783
2784             declare
2785                Dtyp : constant Entity_Id := Designated_Type (Ptyp);
2786                Xtyp : Entity_Id;
2787
2788             begin
2789                if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
2790                   Xtyp := Get_Index_Subtype (N);
2791
2792                   Rewrite (N,
2793                     Make_Attribute_Reference (Loc,
2794                       Prefix         => New_Occurrence_Of (Typ, Loc),
2795                       Attribute_Name => Name_Max,
2796                       Expressions    => New_List (
2797                         Make_Integer_Literal (Loc, 0),
2798
2799                         Make_Op_Add (Loc,
2800                           Make_Integer_Literal (Loc, 1),
2801                           Make_Op_Subtract (Loc,
2802                             Left_Opnd =>
2803                               Make_Attribute_Reference (Loc,
2804                                 Prefix => New_Occurrence_Of (Xtyp, Loc),
2805                                 Attribute_Name => Name_Pos,
2806                                 Expressions    => New_List (
2807                                   Make_Attribute_Reference (Loc,
2808                                     Prefix => Duplicate_Subexpr (Pref),
2809                                     Attribute_Name => Name_Last,
2810                                     Expressions =>
2811                                       New_Copy_List (Exprs)))),
2812
2813                             Right_Opnd =>
2814                               Make_Attribute_Reference (Loc,
2815                                 Prefix => New_Occurrence_Of (Xtyp, Loc),
2816                                 Attribute_Name => Name_Pos,
2817                                 Expressions    => New_List (
2818                                   Make_Attribute_Reference (Loc,
2819                                     Prefix =>
2820                                       Duplicate_Subexpr_No_Checks (Pref),
2821                                     Attribute_Name => Name_First,
2822                                     Expressions =>
2823                                       New_Copy_List (Exprs)))))))));
2824
2825                   Analyze_And_Resolve (N, Typ);
2826                end if;
2827             end;
2828
2829          --  Otherwise leave it to the back end
2830
2831          else
2832             Apply_Universal_Integer_Attribute_Checks (N);
2833          end if;
2834       end;
2835
2836       -------------
2837       -- Machine --
2838       -------------
2839
2840       --  Transforms 'Machine into a call to the floating-point attribute
2841       --  function Machine in Fat_xxx (where xxx is the root type)
2842
2843       when Attribute_Machine =>
2844          Expand_Fpt_Attribute_R (N);
2845
2846       ----------------------
2847       -- Machine_Rounding --
2848       ----------------------
2849
2850       --  Transforms 'Machine_Rounding into a call to the floating-point
2851       --  attribute function Machine_Rounding in Fat_xxx (where xxx is the root
2852       --  type). Expansion is avoided for cases the back end can handle
2853       --  directly.
2854
2855       when Attribute_Machine_Rounding =>
2856          if not Is_Inline_Floating_Point_Attribute (N) then
2857             Expand_Fpt_Attribute_R (N);
2858          end if;
2859
2860       ------------------
2861       -- Machine_Size --
2862       ------------------
2863
2864       --  Machine_Size is equivalent to Object_Size, so transform it into
2865       --  Object_Size and that way the back end never sees Machine_Size.
2866
2867       when Attribute_Machine_Size =>
2868          Rewrite (N,
2869            Make_Attribute_Reference (Loc,
2870              Prefix => Prefix (N),
2871              Attribute_Name => Name_Object_Size));
2872
2873          Analyze_And_Resolve (N, Typ);
2874
2875       --------------
2876       -- Mantissa --
2877       --------------
2878
2879       --  The only case that can get this far is the dynamic case of the old
2880       --  Ada 83 Mantissa attribute for the fixed-point case. For this case,
2881       --  we expand:
2882
2883       --    typ'Mantissa
2884
2885       --  into
2886
2887       --    ityp (System.Mantissa.Mantissa_Value
2888       --           (Integer'Integer_Value (typ'First),
2889       --            Integer'Integer_Value (typ'Last)));
2890
2891       when Attribute_Mantissa => Mantissa : begin
2892          Rewrite (N,
2893            Convert_To (Typ,
2894              Make_Function_Call (Loc,
2895                Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
2896
2897                Parameter_Associations => New_List (
2898
2899                  Make_Attribute_Reference (Loc,
2900                    Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2901                    Attribute_Name => Name_Integer_Value,
2902                    Expressions => New_List (
2903
2904                      Make_Attribute_Reference (Loc,
2905                        Prefix => New_Occurrence_Of (Ptyp, Loc),
2906                        Attribute_Name => Name_First))),
2907
2908                  Make_Attribute_Reference (Loc,
2909                    Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2910                    Attribute_Name => Name_Integer_Value,
2911                    Expressions => New_List (
2912
2913                      Make_Attribute_Reference (Loc,
2914                        Prefix => New_Occurrence_Of (Ptyp, Loc),
2915                        Attribute_Name => Name_Last)))))));
2916
2917          Analyze_And_Resolve (N, Typ);
2918       end Mantissa;
2919
2920       --------------------
2921       -- Mechanism_Code --
2922       --------------------
2923
2924       when Attribute_Mechanism_Code =>
2925
2926          --  We must replace the prefix in the renamed case
2927
2928          if Is_Entity_Name (Pref)
2929            and then Present (Alias (Entity (Pref)))
2930          then
2931             Set_Renamed_Subprogram (Pref, Alias (Entity (Pref)));
2932          end if;
2933
2934       ---------
2935       -- Mod --
2936       ---------
2937
2938       when Attribute_Mod => Mod_Case : declare
2939          Arg  : constant Node_Id := Relocate_Node (First (Exprs));
2940          Hi   : constant Node_Id := Type_High_Bound (Etype (Arg));
2941          Modv : constant Uint    := Modulus (Btyp);
2942
2943       begin
2944
2945          --  This is not so simple. The issue is what type to use for the
2946          --  computation of the modular value.
2947
2948          --  The easy case is when the modulus value is within the bounds
2949          --  of the signed integer type of the argument. In this case we can
2950          --  just do the computation in that signed integer type, and then
2951          --  do an ordinary conversion to the target type.
2952
2953          if Modv <= Expr_Value (Hi) then
2954             Rewrite (N,
2955               Convert_To (Btyp,
2956                 Make_Op_Mod (Loc,
2957                   Left_Opnd  => Arg,
2958                   Right_Opnd => Make_Integer_Literal (Loc, Modv))));
2959
2960          --  Here we know that the modulus is larger than type'Last of the
2961          --  integer type. There are two cases to consider:
2962
2963          --    a) The integer value is non-negative. In this case, it is
2964          --    returned as the result (since it is less than the modulus).
2965
2966          --    b) The integer value is negative. In this case, we know that the
2967          --    result is modulus + value, where the value might be as small as
2968          --    -modulus. The trouble is what type do we use to do the subtract.
2969          --    No type will do, since modulus can be as big as 2**64, and no
2970          --    integer type accommodates this value. Let's do bit of algebra
2971
2972          --         modulus + value
2973          --      =  modulus - (-value)
2974          --      =  (modulus - 1) - (-value - 1)
2975
2976          --    Now modulus - 1 is certainly in range of the modular type.
2977          --    -value is in the range 1 .. modulus, so -value -1 is in the
2978          --    range 0 .. modulus-1 which is in range of the modular type.
2979          --    Furthermore, (-value - 1) can be expressed as -(value + 1)
2980          --    which we can compute using the integer base type.
2981
2982          --  Once this is done we analyze the conditional expression without
2983          --  range checks, because we know everything is in range, and we
2984          --  want to prevent spurious warnings on either branch.
2985
2986          else
2987             Rewrite (N,
2988               Make_Conditional_Expression (Loc,
2989                 Expressions => New_List (
2990                   Make_Op_Ge (Loc,
2991                     Left_Opnd  => Duplicate_Subexpr (Arg),
2992                     Right_Opnd => Make_Integer_Literal (Loc, 0)),
2993
2994                   Convert_To (Btyp,
2995                     Duplicate_Subexpr_No_Checks (Arg)),
2996
2997                   Make_Op_Subtract (Loc,
2998                     Left_Opnd =>
2999                       Make_Integer_Literal (Loc,
3000                         Intval => Modv - 1),
3001                     Right_Opnd =>
3002                       Convert_To (Btyp,
3003                         Make_Op_Minus (Loc,
3004                           Right_Opnd =>
3005                             Make_Op_Add (Loc,
3006                               Left_Opnd  => Duplicate_Subexpr_No_Checks (Arg),
3007                               Right_Opnd =>
3008                                 Make_Integer_Literal (Loc,
3009                                   Intval => 1))))))));
3010
3011          end if;
3012
3013          Analyze_And_Resolve (N, Btyp, Suppress => All_Checks);
3014       end Mod_Case;
3015
3016       -----------
3017       -- Model --
3018       -----------
3019
3020       --  Transforms 'Model into a call to the floating-point attribute
3021       --  function Model in Fat_xxx (where xxx is the root type)
3022
3023       when Attribute_Model =>
3024          Expand_Fpt_Attribute_R (N);
3025
3026       -----------------
3027       -- Object_Size --
3028       -----------------
3029
3030       --  The processing for Object_Size shares the processing for Size
3031
3032       ---------
3033       -- Old --
3034       ---------
3035
3036       when Attribute_Old => Old : declare
3037          Tnn     : constant Entity_Id := Make_Temporary (Loc, 'T', Pref);
3038          Subp    : Node_Id;
3039          Asn_Stm : Node_Id;
3040
3041       begin
3042          --  Find the nearest subprogram body, ignoring _Preconditions
3043
3044          Subp := N;
3045          loop
3046             Subp := Parent (Subp);
3047             exit when Nkind (Subp) = N_Subprogram_Body
3048               and then Chars (Defining_Entity (Subp)) /= Name_uPostconditions;
3049          end loop;
3050
3051          --  Insert the initialized object declaration at the start of the
3052          --  subprogram's declarations.
3053
3054          Asn_Stm :=
3055            Make_Object_Declaration (Loc,
3056              Defining_Identifier => Tnn,
3057              Constant_Present    => True,
3058              Object_Definition   => New_Occurrence_Of (Etype (N), Loc),
3059              Expression          => Pref);
3060
3061          --  Push the subprogram's scope, so that the object will be analyzed
3062          --  in that context (rather than the context of the Precondition
3063          --  subprogram) and will have its Scope set properly.
3064
3065          if Present (Corresponding_Spec (Subp)) then
3066             Push_Scope (Corresponding_Spec (Subp));
3067          else
3068             Push_Scope (Defining_Entity (Subp));
3069          end if;
3070
3071          if Is_Empty_List (Declarations (Subp)) then
3072             Set_Declarations (Subp, New_List (Asn_Stm));
3073             Analyze (Asn_Stm);
3074          else
3075             Insert_Action (First (Declarations (Subp)), Asn_Stm);
3076          end if;
3077
3078          Pop_Scope;
3079
3080          Rewrite (N, New_Occurrence_Of (Tnn, Loc));
3081       end Old;
3082
3083       ------------
3084       -- Output --
3085       ------------
3086
3087       when Attribute_Output => Output : declare
3088          P_Type : constant Entity_Id := Entity (Pref);
3089          U_Type : constant Entity_Id := Underlying_Type (P_Type);
3090          Pname  : Entity_Id;
3091          Decl   : Node_Id;
3092          Prag   : Node_Id;
3093          Arg3   : Node_Id;
3094          Wfunc  : Node_Id;
3095
3096       begin
3097          --  If no underlying type, we have an error that will be diagnosed
3098          --  elsewhere, so here we just completely ignore the expansion.
3099
3100          if No (U_Type) then
3101             return;
3102          end if;
3103
3104          --  If TSS for Output is present, just call it
3105
3106          Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
3107
3108          if Present (Pname) then
3109             null;
3110
3111          else
3112             --  If there is a Stream_Convert pragma, use it, we rewrite
3113
3114             --     sourcetyp'Output (stream, Item)
3115
3116             --  as
3117
3118             --     strmtyp'Output (Stream, strmwrite (acttyp (Item)));
3119
3120             --  where strmwrite is the given Write function that converts an
3121             --  argument of type sourcetyp or a type acctyp, from which it is
3122             --  derived to type strmtyp. The conversion to acttyp is required
3123             --  for the derived case.
3124
3125             Prag := Get_Stream_Convert_Pragma (P_Type);
3126
3127             if Present (Prag) then
3128                Arg3 :=
3129                  Next (Next (First (Pragma_Argument_Associations (Prag))));
3130                Wfunc := Entity (Expression (Arg3));
3131
3132                Rewrite (N,
3133                  Make_Attribute_Reference (Loc,
3134                    Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
3135                    Attribute_Name => Name_Output,
3136                    Expressions => New_List (
3137                    Relocate_Node (First (Exprs)),
3138                      Make_Function_Call (Loc,
3139                        Name => New_Occurrence_Of (Wfunc, Loc),
3140                        Parameter_Associations => New_List (
3141                          OK_Convert_To (Etype (First_Formal (Wfunc)),
3142                            Relocate_Node (Next (First (Exprs)))))))));
3143
3144                Analyze (N);
3145                return;
3146
3147             --  For elementary types, we call the W_xxx routine directly.
3148             --  Note that the effect of Write and Output is identical for
3149             --  the case of an elementary type, since there are no
3150             --  discriminants or bounds.
3151
3152             elsif Is_Elementary_Type (U_Type) then
3153
3154                --  A special case arises if we have a defined _Write routine,
3155                --  since in this case we are required to call this routine.
3156
3157                if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then
3158                   Build_Record_Or_Elementary_Output_Procedure
3159                     (Loc, U_Type, Decl, Pname);
3160                   Insert_Action (N, Decl);
3161
3162                --  For normal cases, we call the W_xxx routine directly
3163
3164                else
3165                   Rewrite (N, Build_Elementary_Write_Call (N));
3166                   Analyze (N);
3167                   return;
3168                end if;
3169
3170             --  Array type case
3171
3172             elsif Is_Array_Type (U_Type) then
3173                Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
3174                Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3175
3176             --  Class-wide case, first output external tag, then dispatch
3177             --  to the appropriate primitive Output function (RM 13.13.2(31)).
3178
3179             elsif Is_Class_Wide_Type (P_Type) then
3180
3181                --  No need to do anything else compiling under restriction
3182                --  No_Dispatching_Calls. During the semantic analysis we
3183                --  already notified such violation.
3184
3185                if Restriction_Active (No_Dispatching_Calls) then
3186                   return;
3187                end if;
3188
3189                Tag_Write : declare
3190                   Strm : constant Node_Id := First (Exprs);
3191                   Item : constant Node_Id := Next (Strm);
3192
3193                begin
3194                   --  Ada 2005 (AI-344): Check that the accessibility level
3195                   --  of the type of the output object is not deeper than
3196                   --  that of the attribute's prefix type.
3197
3198                   --  if Get_Access_Level (Item'Tag)
3199                   --       /= Get_Access_Level (P_Type'Tag)
3200                   --  then
3201                   --     raise Tag_Error;
3202                   --  end if;
3203
3204                   --  String'Output (Strm, External_Tag (Item'Tag));
3205
3206                   --  We cannot figure out a practical way to implement this
3207                   --  accessibility check on virtual machines, so we omit it.
3208
3209                   if Ada_Version >= Ada_2005
3210                     and then Tagged_Type_Expansion
3211                   then
3212                      Insert_Action (N,
3213                        Make_Implicit_If_Statement (N,
3214                          Condition =>
3215                            Make_Op_Ne (Loc,
3216                              Left_Opnd  =>
3217                                Build_Get_Access_Level (Loc,
3218                                  Make_Attribute_Reference (Loc,
3219                                    Prefix         =>
3220                                      Relocate_Node (
3221                                        Duplicate_Subexpr (Item,
3222                                          Name_Req => True)),
3223                                    Attribute_Name => Name_Tag)),
3224
3225                              Right_Opnd =>
3226                                Make_Integer_Literal (Loc,
3227                                  Type_Access_Level (P_Type))),
3228
3229                          Then_Statements =>
3230                            New_List (Make_Raise_Statement (Loc,
3231                                        New_Occurrence_Of (
3232                                          RTE (RE_Tag_Error), Loc)))));
3233                   end if;
3234
3235                   Insert_Action (N,
3236                     Make_Attribute_Reference (Loc,
3237                       Prefix => New_Occurrence_Of (Standard_String, Loc),
3238                       Attribute_Name => Name_Output,
3239                       Expressions => New_List (
3240                         Relocate_Node (Duplicate_Subexpr (Strm)),
3241                         Make_Function_Call (Loc,
3242                           Name =>
3243                             New_Occurrence_Of (RTE (RE_External_Tag), Loc),
3244                           Parameter_Associations => New_List (
3245                            Make_Attribute_Reference (Loc,
3246                              Prefix =>
3247                                Relocate_Node
3248                                  (Duplicate_Subexpr (Item, Name_Req => True)),
3249                              Attribute_Name => Name_Tag))))));
3250                end Tag_Write;
3251
3252                Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
3253
3254             --  Tagged type case, use the primitive Output function
3255
3256             elsif Is_Tagged_Type (U_Type) then
3257                Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
3258
3259             --  All other record type cases, including protected records.
3260             --  The latter only arise for expander generated code for
3261             --  handling shared passive partition access.
3262
3263             else
3264                pragma Assert
3265                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
3266
3267                --  Ada 2005 (AI-216): Program_Error is raised when executing
3268                --  the default implementation of the Output attribute of an
3269                --  unchecked union type if the type lacks default discriminant
3270                --  values.
3271
3272                if Is_Unchecked_Union (Base_Type (U_Type))
3273                  and then No (Discriminant_Constraint (U_Type))
3274                then
3275                   Insert_Action (N,
3276                     Make_Raise_Program_Error (Loc,
3277                       Reason => PE_Unchecked_Union_Restriction));
3278
3279                   return;
3280                end if;
3281
3282                Build_Record_Or_Elementary_Output_Procedure
3283                  (Loc, Base_Type (U_Type), Decl, Pname);
3284                Insert_Action (N, Decl);
3285             end if;
3286          end if;
3287
3288          --  If we fall through, Pname is the name of the procedure to call
3289
3290          Rewrite_Stream_Proc_Call (Pname);
3291       end Output;
3292
3293       ---------
3294       -- Pos --
3295       ---------
3296
3297       --  For enumeration types with a standard representation, Pos is
3298       --  handled by the back end.
3299
3300       --  For enumeration types, with a non-standard representation we generate
3301       --  a call to the _Rep_To_Pos function created when the type was frozen.
3302       --  The call has the form
3303
3304       --    _rep_to_pos (expr, flag)
3305
3306       --  The parameter flag is True if range checks are enabled, causing
3307       --  Program_Error to be raised if the expression has an invalid
3308       --  representation, and False if range checks are suppressed.
3309
3310       --  For integer types, Pos is equivalent to a simple integer
3311       --  conversion and we rewrite it as such
3312
3313       when Attribute_Pos => Pos :
3314       declare
3315          Etyp : Entity_Id := Base_Type (Entity (Pref));
3316
3317       begin
3318          --  Deal with zero/non-zero boolean values
3319
3320          if Is_Boolean_Type (Etyp) then
3321             Adjust_Condition (First (Exprs));
3322             Etyp := Standard_Boolean;
3323             Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
3324          end if;
3325
3326          --  Case of enumeration type
3327
3328          if Is_Enumeration_Type (Etyp) then
3329
3330             --  Non-standard enumeration type (generate call)
3331
3332             if Present (Enum_Pos_To_Rep (Etyp)) then
3333                Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
3334                Rewrite (N,
3335                  Convert_To (Typ,
3336                    Make_Function_Call (Loc,
3337                      Name =>
3338                        New_Reference_To (TSS (Etyp, TSS_Rep_To_Pos), Loc),
3339                      Parameter_Associations => Exprs)));
3340
3341                Analyze_And_Resolve (N, Typ);
3342
3343             --  Standard enumeration type (do universal integer check)
3344
3345             else
3346                Apply_Universal_Integer_Attribute_Checks (N);
3347             end if;
3348
3349          --  Deal with integer types (replace by conversion)
3350
3351          elsif Is_Integer_Type (Etyp) then
3352             Rewrite (N, Convert_To (Typ, First (Exprs)));
3353             Analyze_And_Resolve (N, Typ);
3354          end if;
3355
3356       end Pos;
3357
3358       --------------
3359       -- Position --
3360       --------------
3361
3362       --  We compute this if a component clause was present, otherwise we leave
3363       --  the computation up to the back end, since we don't know what layout
3364       --  will be chosen.
3365
3366       when Attribute_Position => Position :
3367       declare
3368          CE : constant Entity_Id := Entity (Selector_Name (Pref));
3369
3370       begin
3371          if Present (Component_Clause (CE)) then
3372             Rewrite (N,
3373               Make_Integer_Literal (Loc,
3374                 Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
3375             Analyze_And_Resolve (N, Typ);
3376
3377          else
3378             Apply_Universal_Integer_Attribute_Checks (N);
3379          end if;
3380       end Position;
3381
3382       ----------
3383       -- Pred --
3384       ----------
3385
3386       --  1. Deal with enumeration types with holes
3387       --  2. For floating-point, generate call to attribute function
3388       --  3. For other cases, deal with constraint checking
3389
3390       when Attribute_Pred => Pred :
3391       declare
3392          Etyp : constant Entity_Id := Base_Type (Ptyp);
3393
3394       begin
3395
3396          --  For enumeration types with non-standard representations, we
3397          --  expand typ'Pred (x) into
3398
3399          --    Pos_To_Rep (Rep_To_Pos (x) - 1)
3400
3401          --    If the representation is contiguous, we compute instead
3402          --    Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
3403          --    The conversion function Enum_Pos_To_Rep is defined on the
3404          --    base type, not the subtype, so we have to use the base type
3405          --    explicitly for this and other enumeration attributes.
3406
3407          if Is_Enumeration_Type (Ptyp)
3408            and then Present (Enum_Pos_To_Rep (Etyp))
3409          then
3410             if Has_Contiguous_Rep (Etyp) then
3411                Rewrite (N,
3412                   Unchecked_Convert_To (Ptyp,
3413                      Make_Op_Add (Loc,
3414                         Left_Opnd  =>
3415                          Make_Integer_Literal (Loc,
3416                            Enumeration_Rep (First_Literal (Ptyp))),
3417                         Right_Opnd =>
3418                           Make_Function_Call (Loc,
3419                             Name =>
3420                               New_Reference_To
3421                                (TSS (Etyp, TSS_Rep_To_Pos), Loc),
3422
3423                             Parameter_Associations =>
3424                               New_List (
3425                                 Unchecked_Convert_To (Ptyp,
3426                                   Make_Op_Subtract (Loc,
3427                                     Left_Opnd =>
3428                                      Unchecked_Convert_To (Standard_Integer,
3429                                        Relocate_Node (First (Exprs))),
3430                                     Right_Opnd =>
3431                                       Make_Integer_Literal (Loc, 1))),
3432                                 Rep_To_Pos_Flag (Ptyp, Loc))))));
3433
3434             else
3435                --  Add Boolean parameter True, to request program errror if
3436                --  we have a bad representation on our hands. If checks are
3437                --  suppressed, then add False instead
3438
3439                Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
3440                Rewrite (N,
3441                  Make_Indexed_Component (Loc,
3442                    Prefix =>
3443                      New_Reference_To
3444                        (Enum_Pos_To_Rep (Etyp), Loc),
3445                    Expressions => New_List (
3446                      Make_Op_Subtract (Loc,
3447                     Left_Opnd =>
3448                       Make_Function_Call (Loc,
3449                         Name =>
3450                           New_Reference_To
3451                             (TSS (Etyp, TSS_Rep_To_Pos), Loc),
3452                           Parameter_Associations => Exprs),
3453                     Right_Opnd => Make_Integer_Literal (Loc, 1)))));
3454             end if;
3455
3456             Analyze_And_Resolve (N, Typ);
3457
3458          --  For floating-point, we transform 'Pred into a call to the Pred
3459          --  floating-point attribute function in Fat_xxx (xxx is root type)
3460
3461          elsif Is_Floating_Point_Type (Ptyp) then
3462             Expand_Fpt_Attribute_R (N);
3463             Analyze_And_Resolve (N, Typ);
3464
3465          --  For modular types, nothing to do (no overflow, since wraps)
3466
3467          elsif Is_Modular_Integer_Type (Ptyp) then
3468             null;
3469
3470          --  For other types, if argument is marked as needing a range check or
3471          --  overflow checking is enabled, we must generate a check.
3472
3473          elsif not Overflow_Checks_Suppressed (Ptyp)
3474            or else Do_Range_Check (First (Exprs))
3475          then
3476             Set_Do_Range_Check (First (Exprs), False);
3477             Expand_Pred_Succ (N);
3478          end if;
3479       end Pred;
3480
3481       --------------
3482       -- Priority --
3483       --------------
3484
3485       --  Ada 2005 (AI-327): Dynamic ceiling priorities
3486
3487       --  We rewrite X'Priority as the following run-time call:
3488
3489       --     Get_Ceiling (X._Object)
3490
3491       --  Note that although X'Priority is notionally an object, it is quite
3492       --  deliberately not defined as an aliased object in the RM. This means
3493       --  that it works fine to rewrite it as a call, without having to worry
3494       --  about complications that would other arise from X'Priority'Access,
3495       --  which is illegal, because of the lack of aliasing.
3496
3497       when Attribute_Priority =>
3498          declare
3499             Call           : Node_Id;
3500             Conctyp        : Entity_Id;
3501             Object_Parm    : Node_Id;
3502             Subprg         : Entity_Id;
3503             RT_Subprg_Name : Node_Id;
3504
3505          begin
3506             --  Look for the enclosing concurrent type
3507
3508             Conctyp := Current_Scope;
3509             while not Is_Concurrent_Type (Conctyp) loop
3510                Conctyp := Scope (Conctyp);
3511             end loop;
3512
3513             pragma Assert (Is_Protected_Type (Conctyp));
3514
3515             --  Generate the actual of the call
3516
3517             Subprg := Current_Scope;
3518             while not Present (Protected_Body_Subprogram (Subprg)) loop
3519                Subprg := Scope (Subprg);
3520             end loop;
3521
3522             --  Use of 'Priority inside protected entries and barriers (in
3523             --  both cases the type of the first formal of their expanded
3524             --  subprogram is Address)
3525
3526             if Etype (First_Entity (Protected_Body_Subprogram (Subprg)))
3527               = RTE (RE_Address)
3528             then
3529                declare
3530                   New_Itype : Entity_Id;
3531
3532                begin
3533                   --  In the expansion of protected entries the type of the
3534                   --  first formal of the Protected_Body_Subprogram is an
3535                   --  Address. In order to reference the _object component
3536                   --  we generate:
3537
3538                   --    type T is access p__ptTV;
3539                   --    freeze T []
3540
3541                   New_Itype := Create_Itype (E_Access_Type, N);
3542                   Set_Etype (New_Itype, New_Itype);
3543                   Set_Directly_Designated_Type (New_Itype,
3544                     Corresponding_Record_Type (Conctyp));
3545                   Freeze_Itype (New_Itype, N);
3546
3547                   --  Generate:
3548                   --    T!(O)._object'unchecked_access
3549
3550                   Object_Parm :=
3551                     Make_Attribute_Reference (Loc,
3552                       Prefix =>
3553                         Make_Selected_Component (Loc,
3554                           Prefix =>
3555                             Unchecked_Convert_To (New_Itype,
3556                               New_Reference_To
3557                                 (First_Entity
3558                                   (Protected_Body_Subprogram (Subprg)),
3559                                  Loc)),
3560                           Selector_Name =>
3561                             Make_Identifier (Loc, Name_uObject)),
3562                        Attribute_Name => Name_Unchecked_Access);
3563                end;
3564
3565             --  Use of 'Priority inside a protected subprogram
3566
3567             else
3568                Object_Parm :=
3569                  Make_Attribute_Reference (Loc,
3570                     Prefix =>
3571                       Make_Selected_Component (Loc,
3572                         Prefix => New_Reference_To
3573                                     (First_Entity
3574                                       (Protected_Body_Subprogram (Subprg)),
3575                                        Loc),
3576                         Selector_Name => Make_Identifier (Loc, Name_uObject)),
3577                     Attribute_Name => Name_Unchecked_Access);
3578             end if;
3579
3580             --  Select the appropriate run-time subprogram
3581
3582             if Number_Entries (Conctyp) = 0 then
3583                RT_Subprg_Name :=
3584                  New_Reference_To (RTE (RE_Get_Ceiling), Loc);
3585             else
3586                RT_Subprg_Name :=
3587                  New_Reference_To (RTE (RO_PE_Get_Ceiling), Loc);
3588             end if;
3589
3590             Call :=
3591               Make_Function_Call (Loc,
3592                 Name => RT_Subprg_Name,
3593                 Parameter_Associations => New_List (Object_Parm));
3594
3595             Rewrite (N, Call);
3596
3597             --  Avoid the generation of extra checks on the pointer to the
3598             --  protected object.
3599
3600             Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
3601          end;
3602
3603       ------------------
3604       -- Range_Length --
3605       ------------------
3606
3607       when Attribute_Range_Length => Range_Length : begin
3608
3609          --  The only special processing required is for the case where
3610          --  Range_Length is applied to an enumeration type with holes.
3611          --  In this case we transform
3612
3613          --     X'Range_Length
3614
3615          --  to
3616
3617          --     X'Pos (X'Last) - X'Pos (X'First) + 1
3618
3619          --  So that the result reflects the proper Pos values instead
3620          --  of the underlying representations.
3621
3622          if Is_Enumeration_Type (Ptyp)
3623            and then Has_Non_Standard_Rep (Ptyp)
3624          then
3625             Rewrite (N,
3626               Make_Op_Add (Loc,
3627                 Left_Opnd =>
3628                   Make_Op_Subtract (Loc,
3629                     Left_Opnd =>
3630                       Make_Attribute_Reference (Loc,
3631                         Attribute_Name => Name_Pos,
3632                         Prefix => New_Occurrence_Of (Ptyp, Loc),
3633                         Expressions => New_List (
3634                           Make_Attribute_Reference (Loc,
3635                             Attribute_Name => Name_Last,
3636                             Prefix => New_Occurrence_Of (Ptyp, Loc)))),
3637
3638                     Right_Opnd =>
3639                       Make_Attribute_Reference (Loc,
3640                         Attribute_Name => Name_Pos,
3641                         Prefix => New_Occurrence_Of (Ptyp, Loc),
3642                         Expressions => New_List (
3643                           Make_Attribute_Reference (Loc,
3644                             Attribute_Name => Name_First,
3645                             Prefix => New_Occurrence_Of (Ptyp, Loc))))),
3646
3647                 Right_Opnd => Make_Integer_Literal (Loc, 1)));
3648
3649             Analyze_And_Resolve (N, Typ);
3650
3651          --  For all other cases, the attribute is handled by the back end, but
3652          --  we need to deal with the case of the range check on a universal
3653          --  integer.
3654
3655          else
3656             Apply_Universal_Integer_Attribute_Checks (N);
3657          end if;
3658       end Range_Length;
3659
3660       ----------
3661       -- Read --
3662       ----------
3663
3664       when Attribute_Read => Read : declare
3665          P_Type : constant Entity_Id := Entity (Pref);
3666          B_Type : constant Entity_Id := Base_Type (P_Type);
3667          U_Type : constant Entity_Id := Underlying_Type (P_Type);
3668          Pname  : Entity_Id;
3669          Decl   : Node_Id;
3670          Prag   : Node_Id;
3671          Arg2   : Node_Id;
3672          Rfunc  : Node_Id;
3673          Lhs    : Node_Id;
3674          Rhs    : Node_Id;
3675
3676       begin
3677          --  If no underlying type, we have an error that will be diagnosed
3678          --  elsewhere, so here we just completely ignore the expansion.
3679
3680          if No (U_Type) then
3681             return;
3682          end if;
3683
3684          --  The simple case, if there is a TSS for Read, just call it
3685
3686          Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
3687
3688          if Present (Pname) then
3689             null;
3690
3691          else
3692             --  If there is a Stream_Convert pragma, use it, we rewrite
3693
3694             --     sourcetyp'Read (stream, Item)
3695
3696             --  as
3697
3698             --     Item := sourcetyp (strmread (strmtyp'Input (Stream)));
3699
3700             --  where strmread is the given Read function that converts an
3701             --  argument of type strmtyp to type sourcetyp or a type from which
3702             --  it is derived. The conversion to sourcetyp is required in the
3703             --  latter case.
3704
3705             --  A special case arises if Item is a type conversion in which
3706             --  case, we have to expand to:
3707
3708             --     Itemx := typex (strmread (strmtyp'Input (Stream)));
3709
3710             --  where Itemx is the expression of the type conversion (i.e.
3711             --  the actual object), and typex is the type of Itemx.
3712
3713             Prag := Get_Stream_Convert_Pragma (P_Type);
3714
3715             if Present (Prag) then
3716                Arg2  := Next (First (Pragma_Argument_Associations (Prag)));
3717                Rfunc := Entity (Expression (Arg2));
3718                Lhs := Relocate_Node (Next (First (Exprs)));
3719                Rhs :=
3720                  OK_Convert_To (B_Type,
3721                    Make_Function_Call (Loc,
3722                      Name => New_Occurrence_Of (Rfunc, Loc),
3723                      Parameter_Associations => New_List (
3724                        Make_Attribute_Reference (Loc,
3725                          Prefix =>
3726                            New_Occurrence_Of
3727                              (Etype (First_Formal (Rfunc)), Loc),
3728                          Attribute_Name => Name_Input,
3729                          Expressions => New_List (
3730                            Relocate_Node (First (Exprs)))))));
3731
3732                if Nkind (Lhs) = N_Type_Conversion then
3733                   Lhs := Expression (Lhs);
3734                   Rhs := Convert_To (Etype (Lhs), Rhs);
3735                end if;
3736
3737                Rewrite (N,
3738                  Make_Assignment_Statement (Loc,
3739                    Name       => Lhs,
3740                    Expression => Rhs));
3741                Set_Assignment_OK (Lhs);
3742                Analyze (N);
3743                return;
3744
3745             --  For elementary types, we call the I_xxx routine using the first
3746             --  parameter and then assign the result into the second parameter.
3747             --  We set Assignment_OK to deal with the conversion case.
3748
3749             elsif Is_Elementary_Type (U_Type) then
3750                declare
3751                   Lhs : Node_Id;
3752                   Rhs : Node_Id;
3753
3754                begin
3755                   Lhs := Relocate_Node (Next (First (Exprs)));
3756                   Rhs := Build_Elementary_Input_Call (N);
3757
3758                   if Nkind (Lhs) = N_Type_Conversion then
3759                      Lhs := Expression (Lhs);
3760                      Rhs := Convert_To (Etype (Lhs), Rhs);
3761                   end if;
3762
3763                   Set_Assignment_OK (Lhs);
3764
3765                   Rewrite (N,
3766                     Make_Assignment_Statement (Loc,
3767                       Name       => Lhs,
3768                       Expression => Rhs));
3769
3770                   Analyze (N);
3771                   return;
3772                end;
3773
3774             --  Array type case
3775
3776             elsif Is_Array_Type (U_Type) then
3777                Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
3778                Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3779
3780             --  Tagged type case, use the primitive Read function. Note that
3781             --  this will dispatch in the class-wide case which is what we want
3782
3783             elsif Is_Tagged_Type (U_Type) then
3784                Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
3785
3786             --  All other record type cases, including protected records. The
3787             --  latter only arise for expander generated code for handling
3788             --  shared passive partition access.
3789
3790             else
3791                pragma Assert
3792                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
3793
3794                --  Ada 2005 (AI-216): Program_Error is raised when executing
3795                --  the default implementation of the Read attribute of an
3796                --  Unchecked_Union type.
3797
3798                if Is_Unchecked_Union (Base_Type (U_Type)) then
3799                   Insert_Action (N,
3800                     Make_Raise_Program_Error (Loc,
3801                       Reason => PE_Unchecked_Union_Restriction));
3802                end if;
3803
3804                if Has_Discriminants (U_Type)
3805                  and then Present
3806                    (Discriminant_Default_Value (First_Discriminant (U_Type)))
3807                then
3808                   Build_Mutable_Record_Read_Procedure
3809                     (Loc, Full_Base (U_Type), Decl, Pname);
3810                else
3811                   Build_Record_Read_Procedure
3812                     (Loc, Full_Base (U_Type), Decl, Pname);
3813                end if;
3814
3815                --  Suppress checks, uninitialized or otherwise invalid
3816                --  data does not cause constraint errors to be raised for
3817                --  a complete record read.
3818
3819                Insert_Action (N, Decl, All_Checks);
3820             end if;
3821          end if;
3822
3823          Rewrite_Stream_Proc_Call (Pname);
3824       end Read;
3825
3826       ---------
3827       -- Ref --
3828       ---------
3829
3830       --  Ref is identical to To_Address, see To_Address for processing
3831
3832       ---------------
3833       -- Remainder --
3834       ---------------
3835
3836       --  Transforms 'Remainder into a call to the floating-point attribute
3837       --  function Remainder in Fat_xxx (where xxx is the root type)
3838
3839       when Attribute_Remainder =>
3840          Expand_Fpt_Attribute_RR (N);
3841
3842       ------------
3843       -- Result --
3844       ------------
3845
3846       --  Transform 'Result into reference to _Result formal. At the point
3847       --  where a legal 'Result attribute is expanded, we know that we are in
3848       --  the context of a _Postcondition function with a _Result parameter.
3849
3850       when Attribute_Result =>
3851          Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult));
3852          Analyze_And_Resolve (N, Typ);
3853
3854       -----------
3855       -- Round --
3856       -----------
3857
3858       --  The handling of the Round attribute is quite delicate. The processing
3859       --  in Sem_Attr introduced a conversion to universal real, reflecting the
3860       --  semantics of Round, but we do not want anything to do with universal
3861       --  real at runtime, since this corresponds to using floating-point
3862       --  arithmetic.
3863
3864       --  What we have now is that the Etype of the Round attribute correctly
3865       --  indicates the final result type. The operand of the Round is the
3866       --  conversion to universal real, described above, and the operand of
3867       --  this conversion is the actual operand of Round, which may be the
3868       --  special case of a fixed point multiplication or division (Etype =
3869       --  universal fixed)
3870
3871       --  The exapander will expand first the operand of the conversion, then
3872       --  the conversion, and finally the round attribute itself, since we
3873       --  always work inside out. But we cannot simply process naively in this
3874       --  order. In the semantic world where universal fixed and real really
3875       --  exist and have infinite precision, there is no problem, but in the
3876       --  implementation world, where universal real is a floating-point type,
3877       --  we would get the wrong result.
3878
3879       --  So the approach is as follows. First, when expanding a multiply or
3880       --  divide whose type is universal fixed, we do nothing at all, instead
3881       --  deferring the operation till later.
3882
3883       --  The actual processing is done in Expand_N_Type_Conversion which
3884       --  handles the special case of Round by looking at its parent to see if
3885       --  it is a Round attribute, and if it is, handling the conversion (or
3886       --  its fixed multiply/divide child) in an appropriate manner.
3887
3888       --  This means that by the time we get to expanding the Round attribute
3889       --  itself, the Round is nothing more than a type conversion (and will
3890       --  often be a null type conversion), so we just replace it with the
3891       --  appropriate conversion operation.
3892
3893       when Attribute_Round =>
3894          Rewrite (N,
3895            Convert_To (Etype (N), Relocate_Node (First (Exprs))));
3896          Analyze_And_Resolve (N);
3897
3898       --------------
3899       -- Rounding --
3900       --------------
3901
3902       --  Transforms 'Rounding into a call to the floating-point attribute
3903       --  function Rounding in Fat_xxx (where xxx is the root type)
3904
3905       when Attribute_Rounding =>
3906          Expand_Fpt_Attribute_R (N);
3907
3908       -------------
3909       -- Scaling --
3910       -------------
3911
3912       --  Transforms 'Scaling into a call to the floating-point attribute
3913       --  function Scaling in Fat_xxx (where xxx is the root type)
3914
3915       when Attribute_Scaling =>
3916          Expand_Fpt_Attribute_RI (N);
3917
3918       ----------
3919       -- Size --
3920       ----------
3921
3922       when Attribute_Size        |
3923            Attribute_Object_Size |
3924            Attribute_Value_Size  |
3925            Attribute_VADS_Size   => Size :
3926
3927       declare
3928          Siz      : Uint;
3929          New_Node : Node_Id;
3930
3931       begin
3932          --  Processing for VADS_Size case. Note that this processing removes
3933          --  all traces of VADS_Size from the tree, and completes all required
3934          --  processing for VADS_Size by translating the attribute reference
3935          --  to an appropriate Size or Object_Size reference.
3936
3937          if Id = Attribute_VADS_Size
3938            or else (Use_VADS_Size and then Id = Attribute_Size)
3939          then
3940             --  If the size is specified, then we simply use the specified
3941             --  size. This applies to both types and objects. The size of an
3942             --  object can be specified in the following ways:
3943
3944             --    An explicit size object is given for an object
3945             --    A component size is specified for an indexed component
3946             --    A component clause is specified for a selected component
3947             --    The object is a component of a packed composite object
3948
3949             --  If the size is specified, then VADS_Size of an object
3950
3951             if (Is_Entity_Name (Pref)
3952                  and then Present (Size_Clause (Entity (Pref))))
3953               or else
3954                 (Nkind (Pref) = N_Component_Clause
3955                   and then (Present (Component_Clause
3956                                      (Entity (Selector_Name (Pref))))
3957                              or else Is_Packed (Etype (Prefix (Pref)))))
3958               or else
3959                 (Nkind (Pref) = N_Indexed_Component
3960                   and then (Component_Size (Etype (Prefix (Pref))) /= 0
3961                              or else Is_Packed (Etype (Prefix (Pref)))))
3962             then
3963                Set_Attribute_Name (N, Name_Size);
3964
3965             --  Otherwise if we have an object rather than a type, then the
3966             --  VADS_Size attribute applies to the type of the object, rather
3967             --  than the object itself. This is one of the respects in which
3968             --  VADS_Size differs from Size.
3969
3970             else
3971                if (not Is_Entity_Name (Pref)
3972                     or else not Is_Type (Entity (Pref)))
3973                  and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp))
3974                then
3975                   Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
3976                end if;
3977
3978                --  For a scalar type for which no size was explicitly given,
3979                --  VADS_Size means Object_Size. This is the other respect in
3980                --  which VADS_Size differs from Size.
3981
3982                if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then
3983                   Set_Attribute_Name (N, Name_Object_Size);
3984
3985                --  In all other cases, Size and VADS_Size are the sane
3986
3987                else
3988                   Set_Attribute_Name (N, Name_Size);
3989                end if;
3990             end if;
3991          end if;
3992
3993          --  For class-wide types, X'Class'Size is transformed into a direct
3994          --  reference to the Size of the class type, so that the back end does
3995          --  not have to deal with the X'Class'Size reference.
3996
3997          if Is_Entity_Name (Pref)
3998            and then Is_Class_Wide_Type (Entity (Pref))
3999          then
4000             Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
4001             return;
4002
4003          --  For X'Size applied to an object of a class-wide type, transform
4004          --  X'Size into a call to the primitive operation _Size applied to X.
4005
4006          elsif Is_Class_Wide_Type (Ptyp)
4007            or else (Id = Attribute_Size
4008                       and then Is_Tagged_Type (Ptyp)
4009                       and then Has_Unknown_Discriminants (Ptyp))
4010          then
4011             --  No need to do anything else compiling under restriction
4012             --  No_Dispatching_Calls. During the semantic analysis we
4013             --  already notified such violation.
4014
4015             if Restriction_Active (No_Dispatching_Calls) then
4016                return;
4017             end if;
4018
4019             New_Node :=
4020               Make_Function_Call (Loc,
4021                 Name => New_Reference_To
4022                   (Find_Prim_Op (Ptyp, Name_uSize), Loc),
4023                 Parameter_Associations => New_List (Pref));
4024
4025             if Typ /= Standard_Long_Long_Integer then
4026
4027                --  The context is a specific integer type with which the
4028                --  original attribute was compatible. The function has a
4029                --  specific type as well, so to preserve the compatibility
4030                --  we must convert explicitly.
4031
4032                New_Node := Convert_To (Typ, New_Node);
4033             end if;
4034
4035             Rewrite (N, New_Node);
4036             Analyze_And_Resolve (N, Typ);
4037             return;
4038
4039          --  Case of known RM_Size of a type
4040
4041          elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
4042            and then Is_Entity_Name (Pref)
4043            and then Is_Type (Entity (Pref))
4044            and then Known_Static_RM_Size (Entity (Pref))
4045          then
4046             Siz := RM_Size (Entity (Pref));
4047
4048          --  Case of known Esize of a type
4049
4050          elsif Id = Attribute_Object_Size
4051            and then Is_Entity_Name (Pref)
4052            and then Is_Type (Entity (Pref))
4053            and then Known_Static_Esize (Entity (Pref))
4054          then
4055             Siz := Esize (Entity (Pref));
4056
4057          --  Case of known size of object
4058
4059          elsif Id = Attribute_Size
4060            and then Is_Entity_Name (Pref)
4061            and then Is_Object (Entity (Pref))
4062            and then Known_Esize (Entity (Pref))
4063            and then Known_Static_Esize (Entity (Pref))
4064          then
4065             Siz := Esize (Entity (Pref));
4066
4067          --  For an array component, we can do Size in the front end
4068          --  if the component_size of the array is set.
4069
4070          elsif Nkind (Pref) = N_Indexed_Component then
4071             Siz := Component_Size (Etype (Prefix (Pref)));
4072
4073          --  For a record component, we can do Size in the front end if there
4074          --  is a component clause, or if the record is packed and the
4075          --  component's size is known at compile time.
4076
4077          elsif Nkind (Pref) = N_Selected_Component then
4078             declare
4079                Rec  : constant Entity_Id := Etype (Prefix (Pref));
4080                Comp : constant Entity_Id := Entity (Selector_Name (Pref));
4081
4082             begin
4083                if Present (Component_Clause (Comp)) then
4084                   Siz := Esize (Comp);
4085
4086                elsif Is_Packed (Rec) then
4087                   Siz := RM_Size (Ptyp);
4088
4089                else
4090                   Apply_Universal_Integer_Attribute_Checks (N);
4091                   return;
4092                end if;
4093             end;
4094
4095          --  All other cases are handled by the back end
4096
4097          else
4098             Apply_Universal_Integer_Attribute_Checks (N);
4099
4100             --  If Size is applied to a formal parameter that is of a packed
4101             --  array subtype, then apply Size to the actual subtype.
4102
4103             if Is_Entity_Name (Pref)
4104               and then Is_Formal (Entity (Pref))
4105               and then Is_Array_Type (Ptyp)
4106               and then Is_Packed (Ptyp)
4107             then
4108                Rewrite (N,
4109                  Make_Attribute_Reference (Loc,
4110                    Prefix =>
4111                      New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
4112                    Attribute_Name => Name_Size));
4113                Analyze_And_Resolve (N, Typ);
4114             end if;
4115
4116             --  If Size applies to a dereference of an access to unconstrained
4117             --  packed array, the back end needs to see its unconstrained
4118             --  nominal type, but also a hint to the actual constrained type.
4119
4120             if Nkind (Pref) = N_Explicit_Dereference
4121               and then Is_Array_Type (Ptyp)
4122               and then not Is_Constrained (Ptyp)
4123               and then Is_Packed (Ptyp)
4124             then
4125                Set_Actual_Designated_Subtype (Pref,
4126                  Get_Actual_Subtype (Pref));
4127             end if;
4128
4129             return;
4130          end if;
4131
4132          --  Common processing for record and array component case
4133
4134          if Siz /= No_Uint and then Siz /= 0 then
4135             declare
4136                CS : constant Boolean := Comes_From_Source (N);
4137
4138             begin
4139                Rewrite (N, Make_Integer_Literal (Loc, Siz));
4140
4141                --  This integer literal is not a static expression. We do not
4142                --  call Analyze_And_Resolve here, because this would activate
4143                --  the circuit for deciding that a static value was out of
4144                --  range, and we don't want that.
4145
4146                --  So just manually set the type, mark the expression as non-
4147                --  static, and then ensure that the result is checked properly
4148                --  if the attribute comes from source (if it was internally
4149                --  generated, we never need a constraint check).
4150
4151                Set_Etype (N, Typ);
4152                Set_Is_Static_Expression (N, False);
4153
4154                if CS then
4155                   Apply_Constraint_Check (N, Typ);
4156                end if;
4157             end;
4158          end if;
4159       end Size;
4160
4161       ------------------
4162       -- Storage_Pool --
4163       ------------------
4164
4165       when Attribute_Storage_Pool =>
4166          Rewrite (N,
4167            Make_Type_Conversion (Loc,
4168              Subtype_Mark => New_Reference_To (Etype (N), Loc),
4169              Expression   => New_Reference_To (Entity (N), Loc)));
4170          Analyze_And_Resolve (N, Typ);
4171
4172       ------------------
4173       -- Storage_Size --
4174       ------------------
4175
4176       when Attribute_Storage_Size => Storage_Size : begin
4177
4178          --  Access type case, always go to the root type
4179
4180          --  The case of access types results in a value of zero for the case
4181          --  where no storage size attribute clause has been given. If a
4182          --  storage size has been given, then the attribute is converted
4183          --  to a reference to the variable used to hold this value.
4184
4185          if Is_Access_Type (Ptyp) then
4186             if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
4187                Rewrite (N,
4188                  Make_Attribute_Reference (Loc,
4189                    Prefix => New_Reference_To (Typ, Loc),
4190                    Attribute_Name => Name_Max,
4191                    Expressions => New_List (
4192                      Make_Integer_Literal (Loc, 0),
4193                      Convert_To (Typ,
4194                        New_Reference_To
4195                          (Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
4196
4197             elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
4198                Rewrite (N,
4199                  OK_Convert_To (Typ,
4200                    Make_Function_Call (Loc,
4201                      Name =>
4202                        New_Reference_To
4203                          (Find_Prim_Op
4204                            (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
4205                             Attribute_Name (N)),
4206                           Loc),
4207
4208                      Parameter_Associations => New_List (
4209                        New_Reference_To
4210                          (Associated_Storage_Pool (Root_Type (Ptyp)), Loc)))));
4211
4212             else
4213                Rewrite (N, Make_Integer_Literal (Loc, 0));
4214             end if;
4215
4216             Analyze_And_Resolve (N, Typ);
4217
4218          --  For tasks, we retrieve the size directly from the TCB. The
4219          --  size may depend on a discriminant of the type, and therefore
4220          --  can be a per-object expression, so type-level information is
4221          --  not sufficient in general. There are four cases to consider:
4222
4223          --  a) If the attribute appears within a task body, the designated
4224          --    TCB is obtained by a call to Self.
4225
4226          --  b) If the prefix of the attribute is the name of a task object,
4227          --  the designated TCB is the one stored in the corresponding record.
4228
4229          --  c) If the prefix is a task type, the size is obtained from the
4230          --  size variable created for each task type
4231
4232          --  d) If no storage_size was specified for the type , there is no
4233          --  size variable, and the value is a system-specific default.
4234
4235          else
4236             if In_Open_Scopes (Ptyp) then
4237
4238                --  Storage_Size (Self)
4239
4240                Rewrite (N,
4241                  Convert_To (Typ,
4242                    Make_Function_Call (Loc,
4243                      Name =>
4244                        New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
4245                      Parameter_Associations =>
4246                        New_List (
4247                          Make_Function_Call (Loc,
4248                            Name =>
4249                              New_Reference_To (RTE (RE_Self), Loc))))));
4250
4251             elsif not Is_Entity_Name (Pref)
4252               or else not Is_Type (Entity (Pref))
4253             then
4254                --  Storage_Size (Rec (Obj).Size)
4255
4256                Rewrite (N,
4257                  Convert_To (Typ,
4258                    Make_Function_Call (Loc,
4259                      Name =>
4260                        New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
4261                        Parameter_Associations =>
4262                           New_List (
4263                             Make_Selected_Component (Loc,
4264                               Prefix =>
4265                                 Unchecked_Convert_To (
4266                                   Corresponding_Record_Type (Ptyp),
4267                                     New_Copy_Tree (Pref)),
4268                               Selector_Name =>
4269                                  Make_Identifier (Loc, Name_uTask_Id))))));
4270
4271             elsif Present (Storage_Size_Variable (Ptyp)) then
4272
4273                --  Static storage size pragma given for type: retrieve value
4274                --  from its allocated storage variable.
4275
4276                Rewrite (N,
4277                  Convert_To (Typ,
4278                    Make_Function_Call (Loc,
4279                      Name => New_Occurrence_Of (
4280                        RTE (RE_Adjust_Storage_Size), Loc),
4281                      Parameter_Associations =>
4282                        New_List (
4283                          New_Reference_To (
4284                            Storage_Size_Variable (Ptyp), Loc)))));
4285             else
4286                --  Get system default
4287
4288                Rewrite (N,
4289                  Convert_To (Typ,
4290                    Make_Function_Call (Loc,
4291                      Name =>
4292                        New_Occurrence_Of (
4293                         RTE (RE_Default_Stack_Size), Loc))));
4294             end if;
4295
4296             Analyze_And_Resolve (N, Typ);
4297          end if;
4298       end Storage_Size;
4299
4300       -----------------
4301       -- Stream_Size --
4302       -----------------
4303
4304       when Attribute_Stream_Size =>
4305          Rewrite (N,
4306            Make_Integer_Literal (Loc, Intval => Get_Stream_Size (Ptyp)));
4307          Analyze_And_Resolve (N, Typ);
4308
4309       ----------
4310       -- Succ --
4311       ----------
4312
4313       --  1. Deal with enumeration types with holes
4314       --  2. For floating-point, generate call to attribute function
4315       --  3. For other cases, deal with constraint checking
4316
4317       when Attribute_Succ => Succ : declare
4318          Etyp : constant Entity_Id := Base_Type (Ptyp);
4319
4320       begin
4321
4322          --  For enumeration types with non-standard representations, we
4323          --  expand typ'Succ (x) into
4324
4325          --    Pos_To_Rep (Rep_To_Pos (x) + 1)
4326
4327          --    If the representation is contiguous, we compute instead
4328          --    Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
4329
4330          if Is_Enumeration_Type (Ptyp)
4331            and then Present (Enum_Pos_To_Rep (Etyp))
4332          then
4333             if Has_Contiguous_Rep (Etyp) then
4334                Rewrite (N,
4335                   Unchecked_Convert_To (Ptyp,
4336                      Make_Op_Add (Loc,
4337                         Left_Opnd  =>
4338                          Make_Integer_Literal (Loc,
4339                            Enumeration_Rep (First_Literal (Ptyp))),
4340                         Right_Opnd =>
4341                           Make_Function_Call (Loc,
4342                             Name =>
4343                               New_Reference_To
4344                                (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4345
4346                             Parameter_Associations =>
4347                               New_List (
4348                                 Unchecked_Convert_To (Ptyp,
4349                                   Make_Op_Add (Loc,
4350                                   Left_Opnd =>
4351                                     Unchecked_Convert_To (Standard_Integer,
4352                                       Relocate_Node (First (Exprs))),
4353                                   Right_Opnd =>
4354                                     Make_Integer_Literal (Loc, 1))),
4355                                 Rep_To_Pos_Flag (Ptyp, Loc))))));
4356             else
4357                --  Add Boolean parameter True, to request program errror if
4358                --  we have a bad representation on our hands. Add False if
4359                --  checks are suppressed.
4360
4361                Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
4362                Rewrite (N,
4363                  Make_Indexed_Component (Loc,
4364                    Prefix =>
4365                      New_Reference_To
4366                        (Enum_Pos_To_Rep (Etyp), Loc),
4367                    Expressions => New_List (
4368                      Make_Op_Add (Loc,
4369                        Left_Opnd =>
4370                          Make_Function_Call (Loc,
4371                            Name =>
4372                              New_Reference_To
4373                                (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4374                            Parameter_Associations => Exprs),
4375                        Right_Opnd => Make_Integer_Literal (Loc, 1)))));
4376             end if;
4377
4378             Analyze_And_Resolve (N, Typ);
4379
4380          --  For floating-point, we transform 'Succ into a call to the Succ
4381          --  floating-point attribute function in Fat_xxx (xxx is root type)
4382
4383          elsif Is_Floating_Point_Type (Ptyp) then
4384             Expand_Fpt_Attribute_R (N);
4385             Analyze_And_Resolve (N, Typ);
4386
4387          --  For modular types, nothing to do (no overflow, since wraps)
4388
4389          elsif Is_Modular_Integer_Type (Ptyp) then
4390             null;
4391
4392          --  For other types, if argument is marked as needing a range check or
4393          --  overflow checking is enabled, we must generate a check.
4394
4395          elsif not Overflow_Checks_Suppressed (Ptyp)
4396            or else Do_Range_Check (First (Exprs))
4397          then
4398             Set_Do_Range_Check (First (Exprs), False);
4399             Expand_Pred_Succ (N);
4400          end if;
4401       end Succ;
4402
4403       ---------
4404       -- Tag --
4405       ---------
4406
4407       --  Transforms X'Tag into a direct reference to the tag of X
4408
4409       when Attribute_Tag => Tag : declare
4410          Ttyp           : Entity_Id;
4411          Prefix_Is_Type : Boolean;
4412
4413       begin
4414          if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then
4415             Ttyp := Entity (Pref);
4416             Prefix_Is_Type := True;
4417          else
4418             Ttyp := Ptyp;
4419             Prefix_Is_Type := False;
4420          end if;
4421
4422          if Is_Class_Wide_Type (Ttyp) then
4423             Ttyp := Root_Type (Ttyp);
4424          end if;
4425
4426          Ttyp := Underlying_Type (Ttyp);
4427
4428          --  Ada 2005: The type may be a synchronized tagged type, in which
4429          --  case the tag information is stored in the corresponding record.
4430
4431          if Is_Concurrent_Type (Ttyp) then
4432             Ttyp := Corresponding_Record_Type (Ttyp);
4433          end if;
4434
4435          if Prefix_Is_Type then
4436
4437             --  For VMs we leave the type attribute unexpanded because
4438             --  there's not a dispatching table to reference.
4439
4440             if Tagged_Type_Expansion then
4441                Rewrite (N,
4442                  Unchecked_Convert_To (RTE (RE_Tag),
4443                    New_Reference_To
4444                      (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc)));
4445                Analyze_And_Resolve (N, RTE (RE_Tag));
4446             end if;
4447
4448          --  Ada 2005 (AI-251): The use of 'Tag in the sources always
4449          --  references the primary tag of the actual object. If 'Tag is
4450          --  applied to class-wide interface objects we generate code that
4451          --  displaces "this" to reference the base of the object.
4452
4453          elsif Comes_From_Source (N)
4454             and then Is_Class_Wide_Type (Etype (Prefix (N)))
4455             and then Is_Interface (Etype (Prefix (N)))
4456          then
4457             --  Generate:
4458             --    (To_Tag_Ptr (Prefix'Address)).all
4459
4460             --  Note that Prefix'Address is recursively expanded into a call
4461             --  to Base_Address (Obj.Tag)
4462
4463             --  Not needed for VM targets, since all handled by the VM
4464
4465             if Tagged_Type_Expansion then
4466                Rewrite (N,
4467                  Make_Explicit_Dereference (Loc,
4468                    Unchecked_Convert_To (RTE (RE_Tag_Ptr),
4469                      Make_Attribute_Reference (Loc,
4470                        Prefix => Relocate_Node (Pref),
4471                        Attribute_Name => Name_Address))));
4472                Analyze_And_Resolve (N, RTE (RE_Tag));
4473             end if;
4474
4475          else
4476             Rewrite (N,
4477               Make_Selected_Component (Loc,
4478                 Prefix => Relocate_Node (Pref),
4479                 Selector_Name =>
4480                   New_Reference_To (First_Tag_Component (Ttyp), Loc)));
4481             Analyze_And_Resolve (N, RTE (RE_Tag));
4482          end if;
4483       end Tag;
4484
4485       ----------------
4486       -- Terminated --
4487       ----------------
4488
4489       --  Transforms 'Terminated attribute into a call to Terminated function
4490
4491       when Attribute_Terminated => Terminated :
4492       begin
4493          --  The prefix of Terminated is of a task interface class-wide type.
4494          --  Generate:
4495          --    terminated (Task_Id (Pref._disp_get_task_id));
4496
4497          if Ada_Version >= Ada_2005
4498            and then Ekind (Ptyp) = E_Class_Wide_Type
4499            and then Is_Interface (Ptyp)
4500            and then Is_Task_Interface (Ptyp)
4501          then
4502             Rewrite (N,
4503               Make_Function_Call (Loc,
4504                 Name =>
4505                   New_Reference_To (RTE (RE_Terminated), Loc),
4506                 Parameter_Associations => New_List (
4507                   Make_Unchecked_Type_Conversion (Loc,
4508                     Subtype_Mark =>
4509                       New_Reference_To (RTE (RO_ST_Task_Id), Loc),
4510                     Expression =>
4511                       Make_Selected_Component (Loc,
4512                         Prefix =>
4513                           New_Copy_Tree (Pref),
4514                         Selector_Name =>
4515                           Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
4516
4517          elsif Restricted_Profile then
4518             Rewrite (N,
4519               Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
4520
4521          else
4522             Rewrite (N,
4523               Build_Call_With_Task (Pref, RTE (RE_Terminated)));
4524          end if;
4525
4526          Analyze_And_Resolve (N, Standard_Boolean);
4527       end Terminated;
4528
4529       ----------------
4530       -- To_Address --
4531       ----------------
4532
4533       --  Transforms System'To_Address (X) and System.Address'Ref (X) into
4534       --  unchecked conversion from (integral) type of X to type address.
4535
4536       when Attribute_To_Address | Attribute_Ref =>
4537          Rewrite (N,
4538            Unchecked_Convert_To (RTE (RE_Address),
4539              Relocate_Node (First (Exprs))));
4540          Analyze_And_Resolve (N, RTE (RE_Address));
4541
4542       ------------
4543       -- To_Any --
4544       ------------
4545
4546       when Attribute_To_Any => To_Any : declare
4547          P_Type : constant Entity_Id := Etype (Pref);
4548          Decls  : constant List_Id   := New_List;
4549       begin
4550          Rewrite (N,
4551            Build_To_Any_Call
4552              (Convert_To (P_Type,
4553               Relocate_Node (First (Exprs))), Decls));
4554          Insert_Actions (N, Decls);
4555          Analyze_And_Resolve (N, RTE (RE_Any));
4556       end To_Any;
4557
4558       ----------------
4559       -- Truncation --
4560       ----------------
4561
4562       --  Transforms 'Truncation into a call to the floating-point attribute
4563       --  function Truncation in Fat_xxx (where xxx is the root type).
4564       --  Expansion is avoided for cases the back end can handle directly.
4565
4566       when Attribute_Truncation =>
4567          if not Is_Inline_Floating_Point_Attribute (N) then
4568             Expand_Fpt_Attribute_R (N);
4569          end if;
4570
4571       --------------
4572       -- TypeCode --
4573       --------------
4574
4575       when Attribute_TypeCode => TypeCode : declare
4576          P_Type : constant Entity_Id := Etype (Pref);
4577          Decls  : constant List_Id   := New_List;
4578       begin
4579          Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls));
4580          Insert_Actions (N, Decls);
4581          Analyze_And_Resolve (N, RTE (RE_TypeCode));
4582       end TypeCode;
4583
4584       -----------------------
4585       -- Unbiased_Rounding --
4586       -----------------------
4587
4588       --  Transforms 'Unbiased_Rounding into a call to the floating-point
4589       --  attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
4590       --  root type). Expansion is avoided for cases the back end can handle
4591       --  directly.
4592
4593       when Attribute_Unbiased_Rounding =>
4594          if not Is_Inline_Floating_Point_Attribute (N) then
4595             Expand_Fpt_Attribute_R (N);
4596          end if;
4597
4598       -----------------
4599       -- UET_Address --
4600       -----------------
4601
4602       when Attribute_UET_Address => UET_Address : declare
4603          Ent : constant Entity_Id := Make_Temporary (Loc, 'T');
4604
4605       begin
4606          Insert_Action (N,
4607            Make_Object_Declaration (Loc,
4608              Defining_Identifier => Ent,
4609              Aliased_Present     => True,
4610              Object_Definition   =>
4611                New_Occurrence_Of (RTE (RE_Address), Loc)));
4612
4613          --  Construct name __gnat_xxx__SDP, where xxx is the unit name
4614          --  in normal external form.
4615
4616          Get_External_Unit_Name_String (Get_Unit_Name (Pref));
4617          Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
4618          Name_Len := Name_Len + 7;
4619          Name_Buffer (1 .. 7) := "__gnat_";
4620          Name_Buffer (Name_Len + 1 .. Name_Len + 5) := "__SDP";
4621          Name_Len := Name_Len + 5;
4622
4623          Set_Is_Imported (Ent);
4624          Set_Interface_Name (Ent,
4625            Make_String_Literal (Loc,
4626              Strval => String_From_Name_Buffer));
4627
4628          --  Set entity as internal to ensure proper Sprint output of its
4629          --  implicit importation.
4630
4631          Set_Is_Internal (Ent);
4632
4633          Rewrite (N,
4634            Make_Attribute_Reference (Loc,
4635              Prefix => New_Occurrence_Of (Ent, Loc),
4636              Attribute_Name => Name_Address));
4637
4638          Analyze_And_Resolve (N, Typ);
4639       end UET_Address;
4640
4641       ---------------
4642       -- VADS_Size --
4643       ---------------
4644
4645       --  The processing for VADS_Size is shared with Size
4646
4647       ---------
4648       -- Val --
4649       ---------
4650
4651       --  For enumeration types with a standard representation, and for all
4652       --  other types, Val is handled by the back end. For enumeration types
4653       --  with a non-standard representation we use the _Pos_To_Rep array that
4654       --  was created when the type was frozen.
4655
4656       when Attribute_Val => Val : declare
4657          Etyp : constant Entity_Id := Base_Type (Entity (Pref));
4658
4659       begin
4660          if Is_Enumeration_Type (Etyp)
4661            and then Present (Enum_Pos_To_Rep (Etyp))
4662          then
4663             if Has_Contiguous_Rep (Etyp) then
4664                declare
4665                   Rep_Node : constant Node_Id :=
4666                     Unchecked_Convert_To (Etyp,
4667                        Make_Op_Add (Loc,
4668                          Left_Opnd =>
4669                             Make_Integer_Literal (Loc,
4670                               Enumeration_Rep (First_Literal (Etyp))),
4671                          Right_Opnd =>
4672                           (Convert_To (Standard_Integer,
4673                              Relocate_Node (First (Exprs))))));
4674
4675                begin
4676                   Rewrite (N,
4677                      Unchecked_Convert_To (Etyp,
4678                          Make_Op_Add (Loc,
4679                            Left_Opnd =>
4680                              Make_Integer_Literal (Loc,
4681                                Enumeration_Rep (First_Literal (Etyp))),
4682                            Right_Opnd =>
4683                              Make_Function_Call (Loc,
4684                                Name =>
4685                                  New_Reference_To
4686                                    (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4687                                Parameter_Associations => New_List (
4688                                  Rep_Node,
4689                                  Rep_To_Pos_Flag (Etyp, Loc))))));
4690                end;
4691
4692             else
4693                Rewrite (N,
4694                  Make_Indexed_Component (Loc,
4695                    Prefix => New_Reference_To (Enum_Pos_To_Rep (Etyp), Loc),
4696                    Expressions => New_List (
4697                      Convert_To (Standard_Integer,
4698                        Relocate_Node (First (Exprs))))));
4699             end if;
4700
4701             Analyze_And_Resolve (N, Typ);
4702
4703          --  If the argument is marked as requiring a range check then generate
4704          --  it here.
4705
4706          elsif Do_Range_Check (First (Exprs)) then
4707             Set_Do_Range_Check (First (Exprs), False);
4708             Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
4709          end if;
4710       end Val;
4711
4712       -----------
4713       -- Valid --
4714       -----------
4715
4716       --  The code for valid is dependent on the particular types involved.
4717       --  See separate sections below for the generated code in each case.
4718
4719       when Attribute_Valid => Valid : declare
4720          Btyp : Entity_Id := Base_Type (Ptyp);
4721          Tst  : Node_Id;
4722
4723          Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
4724          --  Save the validity checking mode. We always turn off validity
4725          --  checking during process of 'Valid since this is one place
4726          --  where we do not want the implicit validity checks to intefere
4727          --  with the explicit validity check that the programmer is doing.
4728
4729          function Make_Range_Test return Node_Id;
4730          --  Build the code for a range test of the form
4731          --    Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
4732
4733          ---------------------
4734          -- Make_Range_Test --
4735          ---------------------
4736
4737          function Make_Range_Test return Node_Id is
4738             Temp : constant Node_Id := Duplicate_Subexpr (Pref);
4739
4740          begin
4741             --  The value whose validity is being checked has been captured in
4742             --  an object declaration. We certainly don't want this object to
4743             --  appear valid because the declaration initializes it!
4744
4745             if Is_Entity_Name (Temp) then
4746                Set_Is_Known_Valid (Entity (Temp), False);
4747             end if;
4748
4749             return
4750               Make_In (Loc,
4751                 Left_Opnd  =>
4752                   Unchecked_Convert_To (Btyp, Temp),
4753                 Right_Opnd =>
4754                   Make_Range (Loc,
4755                     Low_Bound =>
4756                       Unchecked_Convert_To (Btyp,
4757                         Make_Attribute_Reference (Loc,
4758                           Prefix => New_Occurrence_Of (Ptyp, Loc),
4759                           Attribute_Name => Name_First)),
4760                     High_Bound =>
4761                       Unchecked_Convert_To (Btyp,
4762                         Make_Attribute_Reference (Loc,
4763                           Prefix => New_Occurrence_Of (Ptyp, Loc),
4764                           Attribute_Name => Name_Last))));
4765          end Make_Range_Test;
4766
4767       --  Start of processing for Attribute_Valid
4768
4769       begin
4770          --  Do not expand sourced code 'Valid reference in CodePeer mode,
4771          --  will be handled by the back-end directly.
4772
4773          if CodePeer_Mode and then Comes_From_Source (N) then
4774             return;
4775          end if;
4776
4777          --  Turn off validity checks. We do not want any implicit validity
4778          --  checks to intefere with the explicit check from the attribute
4779
4780          Validity_Checks_On := False;
4781
4782          --  Floating-point case. This case is handled by the Valid attribute
4783          --  code in the floating-point attribute run-time library.
4784
4785          if Is_Floating_Point_Type (Ptyp) then
4786             declare
4787                Pkg : RE_Id;
4788                Ftp : Entity_Id;
4789
4790             begin
4791
4792                case Float_Rep (Btyp) is
4793
4794                   --  For vax fpt types, call appropriate routine in special
4795                   --  vax floating point unit. No need to worry about loads in
4796                   --  this case, since these types have no signalling NaN's.
4797
4798                   when VAX_Native => Expand_Vax_Valid (N);
4799
4800                   --  The AAMP back end handles Valid for floating-point types
4801
4802                   when AAMP =>
4803                      Analyze_And_Resolve (Pref, Ptyp);
4804                      Set_Etype (N, Standard_Boolean);
4805                      Set_Analyzed (N);
4806
4807                   when IEEE_Binary =>
4808                      Find_Fat_Info (Ptyp, Ftp, Pkg);
4809
4810                      --  If the floating-point object might be unaligned, we
4811                      --  need to call the special routine Unaligned_Valid,
4812                      --  which makes the needed copy, being careful not to
4813                      --  load the value into any floating-point register.
4814                      --  The argument in this case is obj'Address (see
4815                      --  Unaligned_Valid routine in Fat_Gen).
4816
4817                      if Is_Possibly_Unaligned_Object (Pref) then
4818                         Expand_Fpt_Attribute
4819                           (N, Pkg, Name_Unaligned_Valid,
4820                            New_List (
4821                              Make_Attribute_Reference (Loc,
4822                                Prefix => Relocate_Node (Pref),
4823                                Attribute_Name => Name_Address)));
4824
4825                      --  In the normal case where we are sure the object is
4826                      --  aligned, we generate a call to Valid, and the argument
4827                      --  in this case is obj'Unrestricted_Access (after
4828                      --  converting obj to the right floating-point type).
4829
4830                      else
4831                         Expand_Fpt_Attribute
4832                           (N, Pkg, Name_Valid,
4833                            New_List (
4834                              Make_Attribute_Reference (Loc,
4835                                Prefix => Unchecked_Convert_To (Ftp, Pref),
4836                                Attribute_Name => Name_Unrestricted_Access)));
4837                      end if;
4838                end case;
4839
4840                --  One more task, we still need a range check. Required
4841                --  only if we have a constraint, since the Valid routine
4842                --  catches infinities properly (infinities are never valid).
4843
4844                --  The way we do the range check is simply to create the
4845                --  expression: Valid (N) and then Base_Type(Pref) in Typ.
4846
4847                if not Subtypes_Statically_Match (Ptyp, Btyp) then
4848                   Rewrite (N,
4849                     Make_And_Then (Loc,
4850                       Left_Opnd  => Relocate_Node (N),
4851                       Right_Opnd =>
4852                         Make_In (Loc,
4853                           Left_Opnd => Convert_To (Btyp, Pref),
4854                           Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
4855                end if;
4856             end;
4857
4858          --  Enumeration type with holes
4859
4860          --  For enumeration types with holes, the Pos value constructed by
4861          --  the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
4862          --  second argument of False returns minus one for an invalid value,
4863          --  and the non-negative pos value for a valid value, so the
4864          --  expansion of X'Valid is simply:
4865
4866          --     type(X)'Pos (X) >= 0
4867
4868          --  We can't quite generate it that way because of the requirement
4869          --  for the non-standard second argument of False in the resulting
4870          --  rep_to_pos call, so we have to explicitly create:
4871
4872          --     _rep_to_pos (X, False) >= 0
4873
4874          --  If we have an enumeration subtype, we also check that the
4875          --  value is in range:
4876
4877          --    _rep_to_pos (X, False) >= 0
4878          --      and then
4879          --       (X >= type(X)'First and then type(X)'Last <= X)
4880
4881          elsif Is_Enumeration_Type (Ptyp)
4882            and then Present (Enum_Pos_To_Rep (Base_Type (Ptyp)))
4883          then
4884             Tst :=
4885               Make_Op_Ge (Loc,
4886                 Left_Opnd =>
4887                   Make_Function_Call (Loc,
4888                     Name =>
4889                       New_Reference_To
4890                         (TSS (Base_Type (Ptyp), TSS_Rep_To_Pos), Loc),
4891                     Parameter_Associations => New_List (
4892                       Pref,
4893                       New_Occurrence_Of (Standard_False, Loc))),
4894                 Right_Opnd => Make_Integer_Literal (Loc, 0));
4895
4896             if Ptyp /= Btyp
4897               and then
4898                 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
4899                   or else
4900                  Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
4901             then
4902                --  The call to Make_Range_Test will create declarations
4903                --  that need a proper insertion point, but Pref is now
4904                --  attached to a node with no ancestor. Attach to tree
4905                --  even if it is to be rewritten below.
4906
4907                Set_Parent (Tst, Parent (N));
4908
4909                Tst :=
4910                  Make_And_Then (Loc,
4911                    Left_Opnd  => Make_Range_Test,
4912                    Right_Opnd => Tst);
4913             end if;
4914
4915             Rewrite (N, Tst);
4916
4917          --  Fortran convention booleans
4918
4919          --  For the very special case of Fortran convention booleans, the
4920          --  value is always valid, since it is an integer with the semantics
4921          --  that non-zero is true, and any value is permissible.
4922
4923          elsif Is_Boolean_Type (Ptyp)
4924            and then Convention (Ptyp) = Convention_Fortran
4925          then
4926             Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
4927
4928          --  For biased representations, we will be doing an unchecked
4929          --  conversion without unbiasing the result. That means that the range
4930          --  test has to take this into account, and the proper form of the
4931          --  test is:
4932
4933          --    Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
4934
4935          elsif Has_Biased_Representation (Ptyp) then
4936             Btyp := RTE (RE_Unsigned_32);
4937             Rewrite (N,
4938               Make_Op_Lt (Loc,
4939                 Left_Opnd =>
4940                   Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
4941                 Right_Opnd =>
4942                   Unchecked_Convert_To (Btyp,
4943                     Make_Attribute_Reference (Loc,
4944                       Prefix => New_Occurrence_Of (Ptyp, Loc),
4945                       Attribute_Name => Name_Range_Length))));
4946
4947          --  For all other scalar types, what we want logically is a
4948          --  range test:
4949
4950          --     X in type(X)'First .. type(X)'Last
4951
4952          --  But that's precisely what won't work because of possible
4953          --  unwanted optimization (and indeed the basic motivation for
4954          --  the Valid attribute is exactly that this test does not work!)
4955          --  What will work is:
4956
4957          --     Btyp!(X) >= Btyp!(type(X)'First)
4958          --       and then
4959          --     Btyp!(X) <= Btyp!(type(X)'Last)
4960
4961          --  where Btyp is an integer type large enough to cover the full
4962          --  range of possible stored values (i.e. it is chosen on the basis
4963          --  of the size of the type, not the range of the values). We write
4964          --  this as two tests, rather than a range check, so that static
4965          --  evaluation will easily remove either or both of the checks if
4966          --  they can be -statically determined to be true (this happens
4967          --  when the type of X is static and the range extends to the full
4968          --  range of stored values).
4969
4970          --  Unsigned types. Note: it is safe to consider only whether the
4971          --  subtype is unsigned, since we will in that case be doing all
4972          --  unsigned comparisons based on the subtype range. Since we use the
4973          --  actual subtype object size, this is appropriate.
4974
4975          --  For example, if we have
4976
4977          --    subtype x is integer range 1 .. 200;
4978          --    for x'Object_Size use 8;
4979
4980          --  Now the base type is signed, but objects of this type are bits
4981          --  unsigned, and doing an unsigned test of the range 1 to 200 is
4982          --  correct, even though a value greater than 127 looks signed to a
4983          --  signed comparison.
4984
4985          elsif Is_Unsigned_Type (Ptyp) then
4986             if Esize (Ptyp) <= 32 then
4987                Btyp := RTE (RE_Unsigned_32);
4988             else
4989                Btyp := RTE (RE_Unsigned_64);
4990             end if;
4991
4992             Rewrite (N, Make_Range_Test);
4993
4994          --  Signed types
4995
4996          else
4997             if Esize (Ptyp) <= Esize (Standard_Integer) then
4998                Btyp := Standard_Integer;
4999             else
5000                Btyp := Universal_Integer;
5001             end if;
5002
5003             Rewrite (N, Make_Range_Test);
5004          end if;
5005
5006          Analyze_And_Resolve (N, Standard_Boolean);
5007          Validity_Checks_On := Save_Validity_Checks_On;
5008       end Valid;
5009
5010       -----------
5011       -- Value --
5012       -----------
5013
5014       --  Value attribute is handled in separate unit Exp_Imgv
5015
5016       when Attribute_Value =>
5017          Exp_Imgv.Expand_Value_Attribute (N);
5018
5019       -----------------
5020       -- Value_Size --
5021       -----------------
5022
5023       --  The processing for Value_Size shares the processing for Size
5024
5025       -------------
5026       -- Version --
5027       -------------
5028
5029       --  The processing for Version shares the processing for Body_Version
5030
5031       ----------------
5032       -- Wide_Image --
5033       ----------------
5034
5035       --  Wide_Image attribute is handled in separate unit Exp_Imgv
5036
5037       when Attribute_Wide_Image =>
5038          Exp_Imgv.Expand_Wide_Image_Attribute (N);
5039
5040       ---------------------
5041       -- Wide_Wide_Image --
5042       ---------------------
5043
5044       --  Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
5045
5046       when Attribute_Wide_Wide_Image =>
5047          Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N);
5048
5049       ----------------
5050       -- Wide_Value --
5051       ----------------
5052
5053       --  We expand typ'Wide_Value (X) into
5054
5055       --    typ'Value
5056       --      (Wide_String_To_String (X, Wide_Character_Encoding_Method))
5057
5058       --  Wide_String_To_String is a runtime function that converts its wide
5059       --  string argument to String, converting any non-translatable characters
5060       --  into appropriate escape sequences. This preserves the required
5061       --  semantics of Wide_Value in all cases, and results in a very simple
5062       --  implementation approach.
5063
5064       --  Note: for this approach to be fully standard compliant for the cases
5065       --  where typ is Wide_Character and Wide_Wide_Character, the encoding
5066       --  method must cover the entire character range (e.g. UTF-8). But that
5067       --  is a reasonable requirement when dealing with encoded character
5068       --  sequences. Presumably if one of the restrictive encoding mechanisms
5069       --  is in use such as Shift-JIS, then characters that cannot be
5070       --  represented using this encoding will not appear in any case.
5071
5072       when Attribute_Wide_Value => Wide_Value :
5073       begin
5074          Rewrite (N,
5075            Make_Attribute_Reference (Loc,
5076              Prefix         => Pref,
5077              Attribute_Name => Name_Value,
5078
5079              Expressions    => New_List (
5080                Make_Function_Call (Loc,
5081                  Name =>
5082                    New_Reference_To (RTE (RE_Wide_String_To_String), Loc),
5083
5084                  Parameter_Associations => New_List (
5085                    Relocate_Node (First (Exprs)),
5086                    Make_Integer_Literal (Loc,
5087                      Intval => Int (Wide_Character_Encoding_Method)))))));
5088
5089          Analyze_And_Resolve (N, Typ);
5090       end Wide_Value;
5091
5092       ---------------------
5093       -- Wide_Wide_Value --
5094       ---------------------
5095
5096       --  We expand typ'Wide_Value_Value (X) into
5097
5098       --    typ'Value
5099       --      (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
5100
5101       --  Wide_Wide_String_To_String is a runtime function that converts its
5102       --  wide string argument to String, converting any non-translatable
5103       --  characters into appropriate escape sequences. This preserves the
5104       --  required semantics of Wide_Wide_Value in all cases, and results in a
5105       --  very simple implementation approach.
5106
5107       --  It's not quite right where typ = Wide_Wide_Character, because the
5108       --  encoding method may not cover the whole character type ???
5109
5110       when Attribute_Wide_Wide_Value => Wide_Wide_Value :
5111       begin
5112          Rewrite (N,
5113            Make_Attribute_Reference (Loc,
5114              Prefix         => Pref,
5115              Attribute_Name => Name_Value,
5116
5117              Expressions    => New_List (
5118                Make_Function_Call (Loc,
5119                  Name =>
5120                    New_Reference_To (RTE (RE_Wide_Wide_String_To_String), Loc),
5121
5122                  Parameter_Associations => New_List (
5123                    Relocate_Node (First (Exprs)),
5124                    Make_Integer_Literal (Loc,
5125                      Intval => Int (Wide_Character_Encoding_Method)))))));
5126
5127          Analyze_And_Resolve (N, Typ);
5128       end Wide_Wide_Value;
5129
5130       ---------------------
5131       -- Wide_Wide_Width --
5132       ---------------------
5133
5134       --  Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
5135
5136       when Attribute_Wide_Wide_Width =>
5137          Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide);
5138
5139       ----------------
5140       -- Wide_Width --
5141       ----------------
5142
5143       --  Wide_Width attribute is handled in separate unit Exp_Imgv
5144
5145       when Attribute_Wide_Width =>
5146          Exp_Imgv.Expand_Width_Attribute (N, Wide);
5147
5148       -----------
5149       -- Width --
5150       -----------
5151
5152       --  Width attribute is handled in separate unit Exp_Imgv
5153
5154       when Attribute_Width =>
5155          Exp_Imgv.Expand_Width_Attribute (N, Normal);
5156
5157       -----------
5158       -- Write --
5159       -----------
5160
5161       when Attribute_Write => Write : declare
5162          P_Type : constant Entity_Id := Entity (Pref);
5163          U_Type : constant Entity_Id := Underlying_Type (P_Type);
5164          Pname  : Entity_Id;
5165          Decl   : Node_Id;
5166          Prag   : Node_Id;
5167          Arg3   : Node_Id;
5168          Wfunc  : Node_Id;
5169
5170       begin
5171          --  If no underlying type, we have an error that will be diagnosed
5172          --  elsewhere, so here we just completely ignore the expansion.
5173
5174          if No (U_Type) then
5175             return;
5176          end if;
5177
5178          --  The simple case, if there is a TSS for Write, just call it
5179
5180          Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
5181
5182          if Present (Pname) then
5183             null;
5184
5185          else
5186             --  If there is a Stream_Convert pragma, use it, we rewrite
5187
5188             --     sourcetyp'Output (stream, Item)
5189
5190             --  as
5191
5192             --     strmtyp'Output (Stream, strmwrite (acttyp (Item)));
5193
5194             --  where strmwrite is the given Write function that converts an
5195             --  argument of type sourcetyp or a type acctyp, from which it is
5196             --  derived to type strmtyp. The conversion to acttyp is required
5197             --  for the derived case.
5198
5199             Prag := Get_Stream_Convert_Pragma (P_Type);
5200
5201             if Present (Prag) then
5202                Arg3 :=
5203                  Next (Next (First (Pragma_Argument_Associations (Prag))));
5204                Wfunc := Entity (Expression (Arg3));
5205
5206                Rewrite (N,
5207                  Make_Attribute_Reference (Loc,
5208                    Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
5209                    Attribute_Name => Name_Output,
5210                    Expressions => New_List (
5211                      Relocate_Node (First (Exprs)),
5212                      Make_Function_Call (Loc,
5213                        Name => New_Occurrence_Of (Wfunc, Loc),
5214                        Parameter_Associations => New_List (
5215                          OK_Convert_To (Etype (First_Formal (Wfunc)),
5216                            Relocate_Node (Next (First (Exprs)))))))));
5217
5218                Analyze (N);
5219                return;
5220
5221             --  For elementary types, we call the W_xxx routine directly
5222
5223             elsif Is_Elementary_Type (U_Type) then
5224                Rewrite (N, Build_Elementary_Write_Call (N));
5225                Analyze (N);
5226                return;
5227
5228             --  Array type case
5229
5230             elsif Is_Array_Type (U_Type) then
5231                Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
5232                Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
5233
5234             --  Tagged type case, use the primitive Write function. Note that
5235             --  this will dispatch in the class-wide case which is what we want
5236
5237             elsif Is_Tagged_Type (U_Type) then
5238                Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
5239
5240             --  All other record type cases, including protected records.
5241             --  The latter only arise for expander generated code for
5242             --  handling shared passive partition access.
5243
5244             else
5245                pragma Assert
5246                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
5247
5248                --  Ada 2005 (AI-216): Program_Error is raised when executing
5249                --  the default implementation of the Write attribute of an
5250                --  Unchecked_Union type. However, if the 'Write reference is
5251                --  within the generated Output stream procedure, Write outputs
5252                --  the components, and the default values of the discriminant
5253                --  are streamed by the Output procedure itself.
5254
5255                if Is_Unchecked_Union (Base_Type (U_Type))
5256                  and not Is_TSS (Current_Scope, TSS_Stream_Output)
5257                then
5258                   Insert_Action (N,
5259                     Make_Raise_Program_Error (Loc,
5260                       Reason => PE_Unchecked_Union_Restriction));
5261                end if;
5262
5263                if Has_Discriminants (U_Type)
5264                  and then Present
5265                    (Discriminant_Default_Value (First_Discriminant (U_Type)))
5266                then
5267                   Build_Mutable_Record_Write_Procedure
5268                     (Loc, Full_Base (U_Type), Decl, Pname);
5269                else
5270                   Build_Record_Write_Procedure
5271                     (Loc, Full_Base (U_Type), Decl, Pname);
5272                end if;
5273
5274                Insert_Action (N, Decl);
5275             end if;
5276          end if;
5277
5278          --  If we fall through, Pname is the procedure to be called
5279
5280          Rewrite_Stream_Proc_Call (Pname);
5281       end Write;
5282
5283       --  Component_Size is handled by the back end, unless the component size
5284       --  is known at compile time, which is always true in the packed array
5285       --  case. It is important that the packed array case is handled in the
5286       --  front end (see Eval_Attribute) since the back end would otherwise get
5287       --  confused by the equivalent packed array type.
5288
5289       when Attribute_Component_Size =>
5290          null;
5291
5292       --  The following attributes are handled by the back end (except that
5293       --  static cases have already been evaluated during semantic processing,
5294       --  but in any case the back end should not count on this). The one bit
5295       --  of special processing required is that these attributes typically
5296       --  generate conditionals in the code, so we need to check the relevant
5297       --  restriction.
5298
5299       when Attribute_Max                          |
5300            Attribute_Min                          =>
5301          Check_Restriction (No_Implicit_Conditionals, N);
5302
5303       --  The following attributes are handled by the back end (except that
5304       --  static cases have already been evaluated during semantic processing,
5305       --  but in any case the back end should not count on this).
5306
5307       --  The back end also handles the non-class-wide cases of Size
5308
5309       when Attribute_Bit_Order                    |
5310            Attribute_Code_Address                 |
5311            Attribute_Definite                     |
5312            Attribute_Null_Parameter               |
5313            Attribute_Passed_By_Reference          |
5314            Attribute_Pool_Address                 =>
5315          null;
5316
5317       --  The following attributes are also handled by the back end, but return
5318       --  a universal integer result, so may need a conversion for checking
5319       --  that the result is in range.
5320
5321       when Attribute_Aft                          |
5322            Attribute_Max_Alignment_For_Allocation |
5323            Attribute_Max_Size_In_Storage_Elements =>
5324          Apply_Universal_Integer_Attribute_Checks (N);
5325
5326       --  The following attributes should not appear at this stage, since they
5327       --  have already been handled by the analyzer (and properly rewritten
5328       --  with corresponding values or entities to represent the right values)
5329
5330       when Attribute_Abort_Signal                 |
5331            Attribute_Address_Size                 |
5332            Attribute_Base                         |
5333            Attribute_Class                        |
5334            Attribute_Compiler_Version             |
5335            Attribute_Default_Bit_Order            |
5336            Attribute_Delta                        |
5337            Attribute_Denorm                       |
5338            Attribute_Digits                       |
5339            Attribute_Emax                         |
5340            Attribute_Enabled                      |
5341            Attribute_Epsilon                      |
5342            Attribute_Fast_Math                    |
5343            Attribute_Has_Access_Values            |
5344            Attribute_Has_Discriminants            |
5345            Attribute_Has_Tagged_Values            |
5346            Attribute_Large                        |
5347            Attribute_Machine_Emax                 |
5348            Attribute_Machine_Emin                 |
5349            Attribute_Machine_Mantissa             |
5350            Attribute_Machine_Overflows            |
5351            Attribute_Machine_Radix                |
5352            Attribute_Machine_Rounds               |
5353            Attribute_Maximum_Alignment            |
5354            Attribute_Model_Emin                   |
5355            Attribute_Model_Epsilon                |
5356            Attribute_Model_Mantissa               |
5357            Attribute_Model_Small                  |
5358            Attribute_Modulus                      |
5359            Attribute_Partition_ID                 |
5360            Attribute_Range                        |
5361            Attribute_Safe_Emax                    |
5362            Attribute_Safe_First                   |
5363            Attribute_Safe_Large                   |
5364            Attribute_Safe_Last                    |
5365            Attribute_Safe_Small                   |
5366            Attribute_Scale                        |
5367            Attribute_Signed_Zeros                 |
5368            Attribute_Small                        |
5369            Attribute_Storage_Unit                 |
5370            Attribute_Stub_Type                    |
5371            Attribute_Target_Name                  |
5372            Attribute_Type_Class                   |
5373            Attribute_Type_Key                     |
5374            Attribute_Unconstrained_Array          |
5375            Attribute_Universal_Literal_String     |
5376            Attribute_Wchar_T_Size                 |
5377            Attribute_Word_Size                    =>
5378          raise Program_Error;
5379
5380       --  The Asm_Input and Asm_Output attributes are not expanded at this
5381       --  stage, but will be eliminated in the expansion of the Asm call, see
5382       --  Exp_Intr for details. So the back end will never see these either.
5383
5384       when Attribute_Asm_Input                    |
5385            Attribute_Asm_Output                   =>
5386          null;
5387       end case;
5388
5389    exception
5390       when RE_Not_Available =>
5391          return;
5392    end Expand_N_Attribute_Reference;
5393
5394    ----------------------
5395    -- Expand_Pred_Succ --
5396    ----------------------
5397
5398    --  For typ'Pred (exp), we generate the check
5399
5400    --    [constraint_error when exp = typ'Base'First]
5401
5402    --  Similarly, for typ'Succ (exp), we generate the check
5403
5404    --    [constraint_error when exp = typ'Base'Last]
5405
5406    --  These checks are not generated for modular types, since the proper
5407    --  semantics for Succ and Pred on modular types is to wrap, not raise CE.
5408    --  We also suppress these checks if we are the right side of an assignment
5409    --  statement or the expression of an object declaration, where the flag
5410    --  Suppress_Assignment_Checks is set for the assignment/declaration.
5411
5412    procedure Expand_Pred_Succ (N : Node_Id) is
5413       Loc  : constant Source_Ptr := Sloc (N);
5414       P    : constant Node_Id    := Parent (N);
5415       Cnam : Name_Id;
5416
5417    begin
5418       if Attribute_Name (N) = Name_Pred then
5419          Cnam := Name_First;
5420       else
5421          Cnam := Name_Last;
5422       end if;
5423
5424       if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration)
5425         or else not Suppress_Assignment_Checks (P)
5426       then
5427          Insert_Action (N,
5428            Make_Raise_Constraint_Error (Loc,
5429              Condition =>
5430                Make_Op_Eq (Loc,
5431                  Left_Opnd =>
5432                    Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
5433                  Right_Opnd =>
5434                    Make_Attribute_Reference (Loc,
5435                      Prefix =>
5436                        New_Reference_To (Base_Type (Etype (Prefix (N))), Loc),
5437                      Attribute_Name => Cnam)),
5438              Reason => CE_Overflow_Check_Failed));
5439       end if;
5440    end Expand_Pred_Succ;
5441
5442    -------------------
5443    -- Find_Fat_Info --
5444    -------------------
5445
5446    procedure Find_Fat_Info
5447      (T        : Entity_Id;
5448       Fat_Type : out Entity_Id;
5449       Fat_Pkg  : out RE_Id)
5450    is
5451       Btyp : constant Entity_Id := Base_Type (T);
5452       Rtyp : constant Entity_Id := Root_Type (T);
5453       Digs : constant Nat       := UI_To_Int (Digits_Value (Btyp));
5454
5455    begin
5456       --  If the base type is VAX float, then get appropriate VAX float type
5457
5458       if Vax_Float (Btyp) then
5459          case Digs is
5460             when 6 =>
5461                Fat_Type := RTE (RE_Fat_VAX_F);
5462                Fat_Pkg  := RE_Attr_VAX_F_Float;
5463
5464             when 9 =>
5465                Fat_Type := RTE (RE_Fat_VAX_D);
5466                Fat_Pkg  := RE_Attr_VAX_D_Float;
5467
5468             when 15 =>
5469                Fat_Type := RTE (RE_Fat_VAX_G);
5470                Fat_Pkg  := RE_Attr_VAX_G_Float;
5471
5472             when others =>
5473                raise Program_Error;
5474          end case;
5475
5476       --  If root type is VAX float, this is the case where the library has
5477       --  been recompiled in VAX float mode, and we have an IEEE float type.
5478       --  This is when we use the special IEEE Fat packages.
5479
5480       elsif Vax_Float (Rtyp) then
5481          case Digs is
5482             when 6 =>
5483                Fat_Type := RTE (RE_Fat_IEEE_Short);
5484                Fat_Pkg  := RE_Attr_IEEE_Short;
5485
5486             when 15 =>
5487                Fat_Type := RTE (RE_Fat_IEEE_Long);
5488                Fat_Pkg  := RE_Attr_IEEE_Long;
5489
5490             when others =>
5491                raise Program_Error;
5492          end case;
5493
5494       --  If neither the base type nor the root type is VAX_Native then VAX
5495       --  float is out of the picture, and we can just use the root type.
5496
5497       else
5498          Fat_Type := Rtyp;
5499
5500          if Fat_Type = Standard_Short_Float then
5501             Fat_Pkg := RE_Attr_Short_Float;
5502
5503          elsif Fat_Type = Standard_Float then
5504             Fat_Pkg := RE_Attr_Float;
5505
5506          elsif Fat_Type = Standard_Long_Float then
5507             Fat_Pkg := RE_Attr_Long_Float;
5508
5509          elsif Fat_Type = Standard_Long_Long_Float then
5510             Fat_Pkg := RE_Attr_Long_Long_Float;
5511
5512          --  Universal real (which is its own root type) is treated as being
5513          --  equivalent to Standard.Long_Long_Float, since it is defined to
5514          --  have the same precision as the longest Float type.
5515
5516          elsif Fat_Type = Universal_Real then
5517             Fat_Type := Standard_Long_Long_Float;
5518             Fat_Pkg := RE_Attr_Long_Long_Float;
5519
5520          else
5521             raise Program_Error;
5522          end if;
5523       end if;
5524    end Find_Fat_Info;
5525
5526    ----------------------------
5527    -- Find_Stream_Subprogram --
5528    ----------------------------
5529
5530    function Find_Stream_Subprogram
5531      (Typ : Entity_Id;
5532       Nam : TSS_Name_Type) return Entity_Id
5533    is
5534       Base_Typ : constant Entity_Id := Base_Type (Typ);
5535       Ent      : constant Entity_Id := TSS (Typ, Nam);
5536
5537       function Is_Available (Entity : RE_Id) return Boolean;
5538       pragma Inline (Is_Available);
5539       --  Function to check whether the specified run-time call is available
5540       --  in the run time used. In the case of a configurable run time, it
5541       --  is normal that some subprograms are not there.
5542
5543       --  I don't understand this routine at all, why is this not just a
5544       --  call to RTE_Available? And if for some reason we need a different
5545       --  routine with different semantics, why is not in Rtsfind ???
5546
5547       ------------------
5548       -- Is_Available --
5549       ------------------
5550
5551       function Is_Available (Entity : RE_Id) return Boolean is
5552       begin
5553          --  Assume that the unit will always be available when using a
5554          --  "normal" (not configurable) run time.
5555
5556          return not Configurable_Run_Time_Mode
5557            or else RTE_Available (Entity);
5558       end Is_Available;
5559
5560    --  Start of processing for Find_Stream_Subprogram
5561
5562    begin
5563       if Present (Ent) then
5564          return Ent;
5565       end if;
5566
5567       --  Stream attributes for strings are expanded into library calls. The
5568       --  following checks are disabled when the run-time is not available or
5569       --  when compiling predefined types due to bootstrap issues. As a result,
5570       --  the compiler will generate in-place stream routines for string types
5571       --  that appear in GNAT's library, but will generate calls via rtsfind
5572       --  to library routines for user code.
5573
5574       --  ??? For now, disable this code for JVM, since this generates a
5575       --  VerifyError exception at run time on e.g. c330001.
5576
5577       --  This is disabled for AAMP, to avoid creating dependences on files not
5578       --  supported in the AAMP library (such as s-fileio.adb).
5579
5580       --  Note: In the case of using a configurable run time, it is very likely
5581       --  that stream routines for string types are not present (they require
5582       --  file system support). In this case, the specific stream routines for
5583       --  strings are not used, relying on the regular stream mechanism
5584       --  instead. That is why we include the test Is_Available when dealing
5585       --  with these cases.
5586
5587       if VM_Target /= JVM_Target
5588         and then not AAMP_On_Target
5589         and then
5590           not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
5591       then
5592          --  String as defined in package Ada
5593
5594          if Base_Typ = Standard_String then
5595             if Restriction_Active (No_Stream_Optimizations) then
5596                if Nam = TSS_Stream_Input
5597                  and then Is_Available (RE_String_Input)
5598                then
5599                   return RTE (RE_String_Input);
5600
5601                elsif Nam = TSS_Stream_Output
5602                  and then Is_Available (RE_String_Output)
5603                then
5604                   return RTE (RE_String_Output);
5605
5606                elsif Nam = TSS_Stream_Read
5607                  and then Is_Available (RE_String_Read)
5608                then
5609                   return RTE (RE_String_Read);
5610
5611                elsif Nam = TSS_Stream_Write
5612                  and then Is_Available (RE_String_Write)
5613                then
5614                   return RTE (RE_String_Write);
5615
5616                elsif Nam /= TSS_Stream_Input and then
5617                      Nam /= TSS_Stream_Output and then
5618                      Nam /= TSS_Stream_Read and then
5619                      Nam /= TSS_Stream_Write
5620                then
5621                   raise Program_Error;
5622                end if;
5623
5624             else
5625                if Nam = TSS_Stream_Input
5626                  and then Is_Available (RE_String_Input_Blk_IO)
5627                then
5628                   return RTE (RE_String_Input_Blk_IO);
5629
5630                elsif Nam = TSS_Stream_Output
5631                  and then Is_Available (RE_String_Output_Blk_IO)
5632                then
5633                   return RTE (RE_String_Output_Blk_IO);
5634
5635                elsif Nam = TSS_Stream_Read
5636                  and then Is_Available (RE_String_Read_Blk_IO)
5637                then
5638                   return RTE (RE_String_Read_Blk_IO);
5639
5640                elsif Nam = TSS_Stream_Write
5641                  and then Is_Available (RE_String_Write_Blk_IO)
5642                then
5643                   return RTE (RE_String_Write_Blk_IO);
5644
5645                elsif Nam /= TSS_Stream_Input and then
5646                      Nam /= TSS_Stream_Output and then
5647                      Nam /= TSS_Stream_Read and then
5648                      Nam /= TSS_Stream_Write
5649                then
5650                   raise Program_Error;
5651                end if;
5652             end if;
5653
5654          --  Wide_String as defined in package Ada
5655
5656          elsif Base_Typ = Standard_Wide_String then
5657             if Restriction_Active (No_Stream_Optimizations) then
5658                if Nam = TSS_Stream_Input
5659                  and then Is_Available (RE_Wide_String_Input)
5660                then
5661                   return RTE (RE_Wide_String_Input);
5662
5663                elsif Nam = TSS_Stream_Output
5664                  and then Is_Available (RE_Wide_String_Output)
5665                then
5666                   return RTE (RE_Wide_String_Output);
5667
5668                elsif Nam = TSS_Stream_Read
5669                  and then Is_Available (RE_Wide_String_Read)
5670                then
5671                   return RTE (RE_Wide_String_Read);
5672
5673                elsif Nam = TSS_Stream_Write
5674                  and then Is_Available (RE_Wide_String_Write)
5675                then
5676                   return RTE (RE_Wide_String_Write);
5677
5678                elsif Nam /= TSS_Stream_Input and then
5679                      Nam /= TSS_Stream_Output and then
5680                      Nam /= TSS_Stream_Read and then
5681                      Nam /= TSS_Stream_Write
5682                then
5683                   raise Program_Error;
5684                end if;
5685
5686             else
5687                if Nam = TSS_Stream_Input
5688                  and then Is_Available (RE_Wide_String_Input_Blk_IO)
5689                then
5690                   return RTE (RE_Wide_String_Input_Blk_IO);
5691
5692                elsif Nam = TSS_Stream_Output
5693                  and then Is_Available (RE_Wide_String_Output_Blk_IO)
5694                then
5695                   return RTE (RE_Wide_String_Output_Blk_IO);
5696
5697                elsif Nam = TSS_Stream_Read
5698                  and then Is_Available (RE_Wide_String_Read_Blk_IO)
5699                then
5700                   return RTE (RE_Wide_String_Read_Blk_IO);
5701
5702                elsif Nam = TSS_Stream_Write
5703                  and then Is_Available (RE_Wide_String_Write_Blk_IO)
5704                then
5705                   return RTE (RE_Wide_String_Write_Blk_IO);
5706
5707                elsif Nam /= TSS_Stream_Input and then
5708                      Nam /= TSS_Stream_Output and then
5709                      Nam /= TSS_Stream_Read and then
5710                      Nam /= TSS_Stream_Write
5711                then
5712                   raise Program_Error;
5713                end if;
5714             end if;
5715
5716          --  Wide_Wide_String as defined in package Ada
5717
5718          elsif Base_Typ = Standard_Wide_Wide_String then
5719             if Restriction_Active (No_Stream_Optimizations) then
5720                if Nam = TSS_Stream_Input
5721                  and then Is_Available (RE_Wide_Wide_String_Input)
5722                then
5723                   return RTE (RE_Wide_Wide_String_Input);
5724
5725                elsif Nam = TSS_Stream_Output
5726                  and then Is_Available (RE_Wide_Wide_String_Output)
5727                then
5728                   return RTE (RE_Wide_Wide_String_Output);
5729
5730                elsif Nam = TSS_Stream_Read
5731                  and then Is_Available (RE_Wide_Wide_String_Read)
5732                then
5733                   return RTE (RE_Wide_Wide_String_Read);
5734
5735                elsif Nam = TSS_Stream_Write
5736                  and then Is_Available (RE_Wide_Wide_String_Write)
5737                then
5738                   return RTE (RE_Wide_Wide_String_Write);
5739
5740                elsif Nam /= TSS_Stream_Input and then
5741                      Nam /= TSS_Stream_Output and then
5742                      Nam /= TSS_Stream_Read and then
5743                      Nam /= TSS_Stream_Write
5744                then
5745                   raise Program_Error;
5746                end if;
5747
5748             else
5749                if Nam = TSS_Stream_Input
5750                  and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO)
5751                then
5752                   return RTE (RE_Wide_Wide_String_Input_Blk_IO);
5753
5754                elsif Nam = TSS_Stream_Output
5755                  and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO)
5756                then
5757                   return RTE (RE_Wide_Wide_String_Output_Blk_IO);
5758
5759                elsif Nam = TSS_Stream_Read
5760                  and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO)
5761                then
5762                   return RTE (RE_Wide_Wide_String_Read_Blk_IO);
5763
5764                elsif Nam = TSS_Stream_Write
5765                  and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO)
5766                then
5767                   return RTE (RE_Wide_Wide_String_Write_Blk_IO);
5768
5769                elsif Nam /= TSS_Stream_Input and then
5770                      Nam /= TSS_Stream_Output and then
5771                      Nam /= TSS_Stream_Read and then
5772                      Nam /= TSS_Stream_Write
5773                then
5774                   raise Program_Error;
5775                end if;
5776             end if;
5777          end if;
5778       end if;
5779
5780       if Is_Tagged_Type (Typ)
5781         and then Is_Derived_Type (Typ)
5782       then
5783          return Find_Prim_Op (Typ, Nam);
5784       else
5785          return Find_Inherited_TSS (Typ, Nam);
5786       end if;
5787    end Find_Stream_Subprogram;
5788
5789    ---------------
5790    -- Full_Base --
5791    ---------------
5792
5793    function Full_Base (T : Entity_Id) return Entity_Id is
5794       BT : Entity_Id;
5795
5796    begin
5797       BT := Base_Type (T);
5798
5799       if Is_Private_Type (BT)
5800         and then Present (Full_View (BT))
5801       then
5802          BT := Full_View (BT);
5803       end if;
5804
5805       return BT;
5806    end Full_Base;
5807
5808    -----------------------
5809    -- Get_Index_Subtype --
5810    -----------------------
5811
5812    function Get_Index_Subtype (N : Node_Id) return Node_Id is
5813       P_Type : Entity_Id := Etype (Prefix (N));
5814       Indx   : Node_Id;
5815       J      : Int;
5816
5817    begin
5818       if Is_Access_Type (P_Type) then
5819          P_Type := Designated_Type (P_Type);
5820       end if;
5821
5822       if No (Expressions (N)) then
5823          J := 1;
5824       else
5825          J := UI_To_Int (Expr_Value (First (Expressions (N))));
5826       end if;
5827
5828       Indx := First_Index (P_Type);
5829       while J > 1 loop
5830          Next_Index (Indx);
5831          J := J - 1;
5832       end loop;
5833
5834       return Etype (Indx);
5835    end Get_Index_Subtype;
5836
5837    -------------------------------
5838    -- Get_Stream_Convert_Pragma --
5839    -------------------------------
5840
5841    function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is
5842       Typ : Entity_Id;
5843       N   : Node_Id;
5844
5845    begin
5846       --  Note: we cannot use Get_Rep_Pragma here because of the peculiarity
5847       --  that a stream convert pragma for a tagged type is not inherited from
5848       --  its parent. Probably what is wrong here is that it is basically
5849       --  incorrect to consider a stream convert pragma to be a representation
5850       --  pragma at all ???
5851
5852       N := First_Rep_Item (Implementation_Base_Type (T));
5853       while Present (N) loop
5854          if Nkind (N) = N_Pragma
5855            and then Pragma_Name (N) = Name_Stream_Convert
5856          then
5857             --  For tagged types this pragma is not inherited, so we
5858             --  must verify that it is defined for the given type and
5859             --  not an ancestor.
5860
5861             Typ :=
5862               Entity (Expression (First (Pragma_Argument_Associations (N))));
5863
5864             if not Is_Tagged_Type (T)
5865               or else T = Typ
5866               or else (Is_Private_Type (Typ) and then T = Full_View (Typ))
5867             then
5868                return N;
5869             end if;
5870          end if;
5871
5872          Next_Rep_Item (N);
5873       end loop;
5874
5875       return Empty;
5876    end Get_Stream_Convert_Pragma;
5877
5878    ---------------------------------
5879    -- Is_Constrained_Packed_Array --
5880    ---------------------------------
5881
5882    function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is
5883       Arr : Entity_Id := Typ;
5884
5885    begin
5886       if Is_Access_Type (Arr) then
5887          Arr := Designated_Type (Arr);
5888       end if;
5889
5890       return Is_Array_Type (Arr)
5891         and then Is_Constrained (Arr)
5892         and then Present (Packed_Array_Type (Arr));
5893    end Is_Constrained_Packed_Array;
5894
5895    ----------------------------------------
5896    -- Is_Inline_Floating_Point_Attribute --
5897    ----------------------------------------
5898
5899    function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is
5900       Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
5901
5902    begin
5903       if Nkind (Parent (N)) /= N_Type_Conversion
5904         or else not Is_Integer_Type (Etype (Parent (N)))
5905       then
5906          return False;
5907       end if;
5908
5909       --  Should also support 'Machine_Rounding and 'Unbiased_Rounding, but
5910       --  required back end support has not been implemented yet ???
5911
5912       return Id = Attribute_Truncation;
5913    end Is_Inline_Floating_Point_Attribute;
5914
5915 end Exp_Attr;