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 Ada 2012 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       -- Descriptor_Size --
1804       ---------------------
1805
1806       when Attribute_Descriptor_Size =>
1807
1808          --  Attribute Descriptor_Size is handled by the back end when applied
1809          --  to an unconstrained array type.
1810
1811          if Is_Array_Type (Ptyp)
1812            and then not Is_Constrained (Ptyp)
1813          then
1814             Apply_Universal_Integer_Attribute_Checks (N);
1815
1816          --  For any other type, the descriptor size is 0 because there is no
1817          --  actual descriptor, but the result is not formally static.
1818
1819          else
1820             Rewrite (N, Make_Integer_Literal (Loc, 0));
1821             Analyze (N);
1822             Set_Is_Static_Expression (N, False);
1823          end if;
1824
1825       ---------------
1826       -- Elab_Body --
1827       ---------------
1828
1829       --  This processing is shared by Elab_Spec
1830
1831       --  What we do is to insert the following declarations
1832
1833       --     procedure tnn;
1834       --     pragma Import (C, enn, "name___elabb/s");
1835
1836       --  and then the Elab_Body/Spec attribute is replaced by a reference
1837       --  to this defining identifier.
1838
1839       when Attribute_Elab_Body      |
1840            Attribute_Elab_Spec      =>
1841
1842          --  Leave attribute unexpanded in CodePeer mode: the gnat2scil
1843          --  back-end knows how to handle these attributes directly.
1844
1845          if CodePeer_Mode then
1846             return;
1847          end if;
1848
1849          Elab_Body : declare
1850             Ent  : constant Entity_Id := Make_Temporary (Loc, 'E');
1851             Str  : String_Id;
1852             Lang : Node_Id;
1853
1854             procedure Make_Elab_String (Nod : Node_Id);
1855             --  Given Nod, an identifier, or a selected component, put the
1856             --  image into the current string literal, with double underline
1857             --  between components.
1858
1859             ----------------------
1860             -- Make_Elab_String --
1861             ----------------------
1862
1863             procedure Make_Elab_String (Nod : Node_Id) is
1864             begin
1865                if Nkind (Nod) = N_Selected_Component then
1866                   Make_Elab_String (Prefix (Nod));
1867
1868                   case VM_Target is
1869                      when JVM_Target =>
1870                         Store_String_Char ('$');
1871                      when CLI_Target =>
1872                         Store_String_Char ('.');
1873                      when No_VM =>
1874                         Store_String_Char ('_');
1875                         Store_String_Char ('_');
1876                   end case;
1877
1878                   Get_Name_String (Chars (Selector_Name (Nod)));
1879
1880                else
1881                   pragma Assert (Nkind (Nod) = N_Identifier);
1882                   Get_Name_String (Chars (Nod));
1883                end if;
1884
1885                Store_String_Chars (Name_Buffer (1 .. Name_Len));
1886             end Make_Elab_String;
1887
1888          --  Start of processing for Elab_Body/Elab_Spec
1889
1890          begin
1891             --  First we need to prepare the string literal for the name of
1892             --  the elaboration routine to be referenced.
1893
1894             Start_String;
1895             Make_Elab_String (Pref);
1896
1897             if VM_Target = No_VM then
1898                Store_String_Chars ("___elab");
1899                Lang := Make_Identifier (Loc, Name_C);
1900             else
1901                Store_String_Chars ("._elab");
1902                Lang := Make_Identifier (Loc, Name_Ada);
1903             end if;
1904
1905             if Id = Attribute_Elab_Body then
1906                Store_String_Char ('b');
1907             else
1908                Store_String_Char ('s');
1909             end if;
1910
1911             Str := End_String;
1912
1913             Insert_Actions (N, New_List (
1914               Make_Subprogram_Declaration (Loc,
1915                 Specification =>
1916                   Make_Procedure_Specification (Loc,
1917                     Defining_Unit_Name => Ent)),
1918
1919               Make_Pragma (Loc,
1920                 Chars => Name_Import,
1921                 Pragma_Argument_Associations => New_List (
1922                   Make_Pragma_Argument_Association (Loc, Expression => Lang),
1923
1924                   Make_Pragma_Argument_Association (Loc,
1925                     Expression => Make_Identifier (Loc, Chars (Ent))),
1926
1927                   Make_Pragma_Argument_Association (Loc,
1928                     Expression => Make_String_Literal (Loc, Str))))));
1929
1930             Set_Entity (N, Ent);
1931             Rewrite (N, New_Occurrence_Of (Ent, Loc));
1932          end Elab_Body;
1933
1934       --------------------
1935       -- Elab_Subp_Body --
1936       --------------------
1937
1938       --  Always ignored. In CodePeer mode, gnat2scil knows how to handle
1939       --  this attribute directly, and if we are not in CodePeer mode it is
1940       --  entirely ignored ???
1941
1942       when Attribute_Elab_Subp_Body =>
1943          return;
1944
1945       ----------------
1946       -- Elaborated --
1947       ----------------
1948
1949       --  Elaborated is always True for preelaborated units, predefined units,
1950       --  pure units and units which have Elaborate_Body pragmas. These units
1951       --  have no elaboration entity.
1952
1953       --  Note: The Elaborated attribute is never passed to the back end
1954
1955       when Attribute_Elaborated => Elaborated : declare
1956          Ent : constant Entity_Id := Entity (Pref);
1957
1958       begin
1959          if Present (Elaboration_Entity (Ent)) then
1960             Rewrite (N,
1961               Make_Op_Ne (Loc,
1962                 Left_Opnd =>
1963                   New_Occurrence_Of (Elaboration_Entity (Ent), Loc),
1964                 Right_Opnd =>
1965                   Make_Integer_Literal (Loc, Uint_0)));
1966             Analyze_And_Resolve (N, Typ);
1967          else
1968             Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
1969          end if;
1970       end Elaborated;
1971
1972       --------------
1973       -- Enum_Rep --
1974       --------------
1975
1976       when Attribute_Enum_Rep => Enum_Rep :
1977       begin
1978          --  X'Enum_Rep (Y) expands to
1979
1980          --    target-type (Y)
1981
1982          --  This is simply a direct conversion from the enumeration type to
1983          --  the target integer type, which is treated by the back end as a
1984          --  normal integer conversion, treating the enumeration type as an
1985          --  integer, which is exactly what we want! We set Conversion_OK to
1986          --  make sure that the analyzer does not complain about what otherwise
1987          --  might be an illegal conversion.
1988
1989          if Is_Non_Empty_List (Exprs) then
1990             Rewrite (N,
1991               OK_Convert_To (Typ, Relocate_Node (First (Exprs))));
1992
1993          --  X'Enum_Rep where X is an enumeration literal is replaced by
1994          --  the literal value.
1995
1996          elsif Ekind (Entity (Pref)) = E_Enumeration_Literal then
1997             Rewrite (N,
1998               Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref))));
1999
2000          --  If this is a renaming of a literal, recover the representation
2001          --  of the original.
2002
2003          elsif Ekind (Entity (Pref)) = E_Constant
2004            and then Present (Renamed_Object (Entity (Pref)))
2005            and then
2006              Ekind (Entity (Renamed_Object (Entity (Pref))))
2007                = E_Enumeration_Literal
2008          then
2009             Rewrite (N,
2010               Make_Integer_Literal (Loc,
2011                 Enumeration_Rep (Entity (Renamed_Object (Entity (Pref))))));
2012
2013          --  X'Enum_Rep where X is an object does a direct unchecked conversion
2014          --  of the object value, as described for the type case above.
2015
2016          else
2017             Rewrite (N,
2018               OK_Convert_To (Typ, Relocate_Node (Pref)));
2019          end if;
2020
2021          Set_Etype (N, Typ);
2022          Analyze_And_Resolve (N, Typ);
2023       end Enum_Rep;
2024
2025       --------------
2026       -- Enum_Val --
2027       --------------
2028
2029       when Attribute_Enum_Val => Enum_Val : declare
2030          Expr : Node_Id;
2031          Btyp : constant Entity_Id  := Base_Type (Ptyp);
2032
2033       begin
2034          --  X'Enum_Val (Y) expands to
2035
2036          --    [constraint_error when _rep_to_pos (Y, False) = -1, msg]
2037          --    X!(Y);
2038
2039          Expr := Unchecked_Convert_To (Ptyp, First (Exprs));
2040
2041          Insert_Action (N,
2042            Make_Raise_Constraint_Error (Loc,
2043              Condition =>
2044                Make_Op_Eq (Loc,
2045                  Left_Opnd =>
2046                    Make_Function_Call (Loc,
2047                      Name =>
2048                        New_Reference_To (TSS (Btyp, TSS_Rep_To_Pos), Loc),
2049                      Parameter_Associations => New_List (
2050                        Relocate_Node (Duplicate_Subexpr (Expr)),
2051                          New_Occurrence_Of (Standard_False, Loc))),
2052
2053                  Right_Opnd => Make_Integer_Literal (Loc, -1)),
2054              Reason => CE_Range_Check_Failed));
2055
2056          Rewrite (N, Expr);
2057          Analyze_And_Resolve (N, Ptyp);
2058       end Enum_Val;
2059
2060       --------------
2061       -- Exponent --
2062       --------------
2063
2064       --  Transforms 'Exponent into a call to the floating-point attribute
2065       --  function Exponent in Fat_xxx (where xxx is the root type)
2066
2067       when Attribute_Exponent =>
2068          Expand_Fpt_Attribute_R (N);
2069
2070       ------------------
2071       -- External_Tag --
2072       ------------------
2073
2074       --  transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
2075
2076       when Attribute_External_Tag => External_Tag :
2077       begin
2078          Rewrite (N,
2079            Make_Function_Call (Loc,
2080              Name => New_Reference_To (RTE (RE_External_Tag), Loc),
2081              Parameter_Associations => New_List (
2082                Make_Attribute_Reference (Loc,
2083                  Attribute_Name => Name_Tag,
2084                  Prefix => Prefix (N)))));
2085
2086          Analyze_And_Resolve (N, Standard_String);
2087       end External_Tag;
2088
2089       -----------
2090       -- First --
2091       -----------
2092
2093       when Attribute_First =>
2094
2095          --  If the prefix type is a constrained packed array type which
2096          --  already has a Packed_Array_Type representation defined, then
2097          --  replace this attribute with a direct reference to 'First of the
2098          --  appropriate index subtype (since otherwise the back end will try
2099          --  to give us the value of 'First for this implementation type).
2100
2101          if Is_Constrained_Packed_Array (Ptyp) then
2102             Rewrite (N,
2103               Make_Attribute_Reference (Loc,
2104                 Attribute_Name => Name_First,
2105                 Prefix => New_Reference_To (Get_Index_Subtype (N), Loc)));
2106             Analyze_And_Resolve (N, Typ);
2107
2108          elsif Is_Access_Type (Ptyp) then
2109             Apply_Access_Check (N);
2110          end if;
2111
2112       ---------------
2113       -- First_Bit --
2114       ---------------
2115
2116       --  Compute this if component clause was present, otherwise we leave the
2117       --  computation to be completed in the back-end, since we don't know what
2118       --  layout will be chosen.
2119
2120       when Attribute_First_Bit => First_Bit : declare
2121          CE : constant Entity_Id := Entity (Selector_Name (Pref));
2122
2123       begin
2124          if Known_Static_Component_Bit_Offset (CE) then
2125             Rewrite (N,
2126               Make_Integer_Literal (Loc,
2127                 Component_Bit_Offset (CE) mod System_Storage_Unit));
2128
2129             Analyze_And_Resolve (N, Typ);
2130
2131          else
2132             Apply_Universal_Integer_Attribute_Checks (N);
2133          end if;
2134       end First_Bit;
2135
2136       -----------------
2137       -- Fixed_Value --
2138       -----------------
2139
2140       --  We transform:
2141
2142       --     fixtype'Fixed_Value (integer-value)
2143
2144       --  into
2145
2146       --     fixtype(integer-value)
2147
2148       --  We do all the required analysis of the conversion here, because we do
2149       --  not want this to go through the fixed-point conversion circuits. Note
2150       --  that the back end always treats fixed-point as equivalent to the
2151       --  corresponding integer type anyway.
2152
2153       when Attribute_Fixed_Value => Fixed_Value :
2154       begin
2155          Rewrite (N,
2156            Make_Type_Conversion (Loc,
2157              Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
2158              Expression   => Relocate_Node (First (Exprs))));
2159          Set_Etype (N, Entity (Pref));
2160          Set_Analyzed (N);
2161
2162       --  Note: it might appear that a properly analyzed unchecked conversion
2163       --  would be just fine here, but that's not the case, since the full
2164       --  range checks performed by the following call are critical!
2165
2166          Apply_Type_Conversion_Checks (N);
2167       end Fixed_Value;
2168
2169       -----------
2170       -- Floor --
2171       -----------
2172
2173       --  Transforms 'Floor into a call to the floating-point attribute
2174       --  function Floor in Fat_xxx (where xxx is the root type)
2175
2176       when Attribute_Floor =>
2177          Expand_Fpt_Attribute_R (N);
2178
2179       ----------
2180       -- Fore --
2181       ----------
2182
2183       --  For the fixed-point type Typ:
2184
2185       --    Typ'Fore
2186
2187       --  expands into
2188
2189       --    Result_Type (System.Fore (Universal_Real (Type'First)),
2190       --                              Universal_Real (Type'Last))
2191
2192       --  Note that we know that the type is a non-static subtype, or Fore
2193       --  would have itself been computed dynamically in Eval_Attribute.
2194
2195       when Attribute_Fore => Fore : begin
2196          Rewrite (N,
2197            Convert_To (Typ,
2198              Make_Function_Call (Loc,
2199                Name => New_Reference_To (RTE (RE_Fore), Loc),
2200
2201                Parameter_Associations => New_List (
2202                  Convert_To (Universal_Real,
2203                    Make_Attribute_Reference (Loc,
2204                      Prefix => New_Reference_To (Ptyp, Loc),
2205                      Attribute_Name => Name_First)),
2206
2207                  Convert_To (Universal_Real,
2208                    Make_Attribute_Reference (Loc,
2209                      Prefix => New_Reference_To (Ptyp, Loc),
2210                      Attribute_Name => Name_Last))))));
2211
2212          Analyze_And_Resolve (N, Typ);
2213       end Fore;
2214
2215       --------------
2216       -- Fraction --
2217       --------------
2218
2219       --  Transforms 'Fraction into a call to the floating-point attribute
2220       --  function Fraction in Fat_xxx (where xxx is the root type)
2221
2222       when Attribute_Fraction =>
2223          Expand_Fpt_Attribute_R (N);
2224
2225       --------------
2226       -- From_Any --
2227       --------------
2228
2229       when Attribute_From_Any => From_Any : declare
2230          P_Type : constant Entity_Id := Etype (Pref);
2231          Decls  : constant List_Id   := New_List;
2232       begin
2233          Rewrite (N,
2234            Build_From_Any_Call (P_Type,
2235              Relocate_Node (First (Exprs)),
2236              Decls));
2237          Insert_Actions (N, Decls);
2238          Analyze_And_Resolve (N, P_Type);
2239       end From_Any;
2240
2241       --------------
2242       -- Identity --
2243       --------------
2244
2245       --  For an exception returns a reference to the exception data:
2246       --      Exception_Id!(Prefix'Reference)
2247
2248       --  For a task it returns a reference to the _task_id component of
2249       --  corresponding record:
2250
2251       --    taskV!(Prefix)._Task_Id, converted to the type Task_Id defined
2252
2253       --  in Ada.Task_Identification
2254
2255       when Attribute_Identity => Identity : declare
2256          Id_Kind : Entity_Id;
2257
2258       begin
2259          if Ptyp = Standard_Exception_Type then
2260             Id_Kind := RTE (RE_Exception_Id);
2261
2262             if Present (Renamed_Object (Entity (Pref))) then
2263                Set_Entity (Pref, Renamed_Object (Entity (Pref)));
2264             end if;
2265
2266             Rewrite (N,
2267               Unchecked_Convert_To (Id_Kind, Make_Reference (Loc, Pref)));
2268          else
2269             Id_Kind := RTE (RO_AT_Task_Id);
2270
2271             --  If the prefix is a task interface, the Task_Id is obtained
2272             --  dynamically through a dispatching call, as for other task
2273             --  attributes applied to interfaces.
2274
2275             if Ada_Version >= Ada_2005
2276               and then Ekind (Ptyp) = E_Class_Wide_Type
2277               and then Is_Interface (Ptyp)
2278               and then Is_Task_Interface (Ptyp)
2279             then
2280                Rewrite (N,
2281                  Unchecked_Convert_To (Id_Kind,
2282                    Make_Selected_Component (Loc,
2283                      Prefix =>
2284                        New_Copy_Tree (Pref),
2285                      Selector_Name =>
2286                        Make_Identifier (Loc, Name_uDisp_Get_Task_Id))));
2287
2288             else
2289                Rewrite (N,
2290                  Unchecked_Convert_To (Id_Kind, Concurrent_Ref (Pref)));
2291             end if;
2292          end if;
2293
2294          Analyze_And_Resolve (N, Id_Kind);
2295       end Identity;
2296
2297       -----------
2298       -- Image --
2299       -----------
2300
2301       --  Image attribute is handled in separate unit Exp_Imgv
2302
2303       when Attribute_Image =>
2304          Exp_Imgv.Expand_Image_Attribute (N);
2305
2306       ---------
2307       -- Img --
2308       ---------
2309
2310       --  X'Img is expanded to typ'Image (X), where typ is the type of X
2311
2312       when Attribute_Img => Img :
2313       begin
2314          Rewrite (N,
2315            Make_Attribute_Reference (Loc,
2316              Prefix => New_Reference_To (Ptyp, Loc),
2317              Attribute_Name => Name_Image,
2318              Expressions => New_List (Relocate_Node (Pref))));
2319
2320          Analyze_And_Resolve (N, Standard_String);
2321       end Img;
2322
2323       -----------
2324       -- Input --
2325       -----------
2326
2327       when Attribute_Input => Input : declare
2328          P_Type : constant Entity_Id := Entity (Pref);
2329          B_Type : constant Entity_Id := Base_Type (P_Type);
2330          U_Type : constant Entity_Id := Underlying_Type (P_Type);
2331          Strm   : constant Node_Id   := First (Exprs);
2332          Fname  : Entity_Id;
2333          Decl   : Node_Id;
2334          Call   : Node_Id;
2335          Prag   : Node_Id;
2336          Arg2   : Node_Id;
2337          Rfunc  : Node_Id;
2338
2339          Cntrl  : Node_Id := Empty;
2340          --  Value for controlling argument in call. Always Empty except in
2341          --  the dispatching (class-wide type) case, where it is a reference
2342          --  to the dummy object initialized to the right internal tag.
2343
2344          procedure Freeze_Stream_Subprogram (F : Entity_Id);
2345          --  The expansion of the attribute reference may generate a call to
2346          --  a user-defined stream subprogram that is frozen by the call. This
2347          --  can lead to access-before-elaboration problem if the reference
2348          --  appears in an object declaration and the subprogram body has not
2349          --  been seen. The freezing of the subprogram requires special code
2350          --  because it appears in an expanded context where expressions do
2351          --  not freeze their constituents.
2352
2353          ------------------------------
2354          -- Freeze_Stream_Subprogram --
2355          ------------------------------
2356
2357          procedure Freeze_Stream_Subprogram (F : Entity_Id) is
2358             Decl : constant Node_Id := Unit_Declaration_Node (F);
2359             Bod  : Node_Id;
2360
2361          begin
2362             --  If this is user-defined subprogram, the corresponding
2363             --  stream function appears as a renaming-as-body, and the
2364             --  user subprogram must be retrieved by tree traversal.
2365
2366             if Present (Decl)
2367               and then Nkind (Decl) = N_Subprogram_Declaration
2368               and then Present (Corresponding_Body (Decl))
2369             then
2370                Bod := Corresponding_Body (Decl);
2371
2372                if Nkind (Unit_Declaration_Node (Bod)) =
2373                  N_Subprogram_Renaming_Declaration
2374                then
2375                   Set_Is_Frozen (Entity (Name (Unit_Declaration_Node (Bod))));
2376                end if;
2377             end if;
2378          end Freeze_Stream_Subprogram;
2379
2380       --  Start of processing for Input
2381
2382       begin
2383          --  If no underlying type, we have an error that will be diagnosed
2384          --  elsewhere, so here we just completely ignore the expansion.
2385
2386          if No (U_Type) then
2387             return;
2388          end if;
2389
2390          --  If there is a TSS for Input, just call it
2391
2392          Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
2393
2394          if Present (Fname) then
2395             null;
2396
2397          else
2398             --  If there is a Stream_Convert pragma, use it, we rewrite
2399
2400             --     sourcetyp'Input (stream)
2401
2402             --  as
2403
2404             --     sourcetyp (streamread (strmtyp'Input (stream)));
2405
2406             --  where streamread is the given Read function that converts an
2407             --  argument of type strmtyp to type sourcetyp or a type from which
2408             --  it is derived (extra conversion required for the derived case).
2409
2410             Prag := Get_Stream_Convert_Pragma (P_Type);
2411
2412             if Present (Prag) then
2413                Arg2  := Next (First (Pragma_Argument_Associations (Prag)));
2414                Rfunc := Entity (Expression (Arg2));
2415
2416                Rewrite (N,
2417                  Convert_To (B_Type,
2418                    Make_Function_Call (Loc,
2419                      Name => New_Occurrence_Of (Rfunc, Loc),
2420                      Parameter_Associations => New_List (
2421                        Make_Attribute_Reference (Loc,
2422                          Prefix =>
2423                            New_Occurrence_Of
2424                              (Etype (First_Formal (Rfunc)), Loc),
2425                          Attribute_Name => Name_Input,
2426                          Expressions => Exprs)))));
2427
2428                Analyze_And_Resolve (N, B_Type);
2429                return;
2430
2431             --  Elementary types
2432
2433             elsif Is_Elementary_Type (U_Type) then
2434
2435                --  A special case arises if we have a defined _Read routine,
2436                --  since in this case we are required to call this routine.
2437
2438                if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then
2439                   Build_Record_Or_Elementary_Input_Function
2440                     (Loc, U_Type, Decl, Fname);
2441                   Insert_Action (N, Decl);
2442
2443                --  For normal cases, we call the I_xxx routine directly
2444
2445                else
2446                   Rewrite (N, Build_Elementary_Input_Call (N));
2447                   Analyze_And_Resolve (N, P_Type);
2448                   return;
2449                end if;
2450
2451             --  Array type case
2452
2453             elsif Is_Array_Type (U_Type) then
2454                Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
2455                Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
2456
2457             --  Dispatching case with class-wide type
2458
2459             elsif Is_Class_Wide_Type (P_Type) then
2460
2461                --  No need to do anything else compiling under restriction
2462                --  No_Dispatching_Calls. During the semantic analysis we
2463                --  already notified such violation.
2464
2465                if Restriction_Active (No_Dispatching_Calls) then
2466                   return;
2467                end if;
2468
2469                declare
2470                   Rtyp : constant Entity_Id := Root_Type (P_Type);
2471                   Dnn  : Entity_Id;
2472                   Decl : Node_Id;
2473                   Expr : Node_Id;
2474
2475                begin
2476                   --  Read the internal tag (RM 13.13.2(34)) and use it to
2477                   --  initialize a dummy tag object:
2478
2479                   --    Dnn : Ada.Tags.Tag :=
2480                   --            Descendant_Tag (String'Input (Strm), P_Type);
2481
2482                   --  This dummy object is used only to provide a controlling
2483                   --  argument for the eventual _Input call. Descendant_Tag is
2484                   --  called rather than Internal_Tag to ensure that we have a
2485                   --  tag for a type that is descended from the prefix type and
2486                   --  declared at the same accessibility level (the exception
2487                   --  Tag_Error will be raised otherwise). The level check is
2488                   --  required for Ada 2005 because tagged types can be
2489                   --  extended in nested scopes (AI-344).
2490
2491                   Expr :=
2492                     Make_Function_Call (Loc,
2493                       Name =>
2494                         New_Occurrence_Of (RTE (RE_Descendant_Tag), Loc),
2495                       Parameter_Associations => New_List (
2496                         Make_Attribute_Reference (Loc,
2497                           Prefix => New_Occurrence_Of (Standard_String, Loc),
2498                           Attribute_Name => Name_Input,
2499                           Expressions => New_List (
2500                             Relocate_Node (Duplicate_Subexpr (Strm)))),
2501                         Make_Attribute_Reference (Loc,
2502                           Prefix => New_Reference_To (P_Type, Loc),
2503                           Attribute_Name => Name_Tag)));
2504
2505                   Dnn := Make_Temporary (Loc, 'D', Expr);
2506
2507                   Decl :=
2508                     Make_Object_Declaration (Loc,
2509                       Defining_Identifier => Dnn,
2510                       Object_Definition   =>
2511                         New_Occurrence_Of (RTE (RE_Tag), Loc),
2512                       Expression          => Expr);
2513
2514                   Insert_Action (N, Decl);
2515
2516                   --  Now we need to get the entity for the call, and construct
2517                   --  a function call node, where we preset a reference to Dnn
2518                   --  as the controlling argument (doing an unchecked convert
2519                   --  to the class-wide tagged type to make it look like a real
2520                   --  tagged object).
2521
2522                   Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
2523                   Cntrl :=
2524                     Unchecked_Convert_To (P_Type,
2525                       New_Occurrence_Of (Dnn, Loc));
2526                   Set_Etype (Cntrl, P_Type);
2527                   Set_Parent (Cntrl, N);
2528                end;
2529
2530             --  For tagged types, use the primitive Input function
2531
2532             elsif Is_Tagged_Type (U_Type) then
2533                Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
2534
2535             --  All other record type cases, including protected records. The
2536             --  latter only arise for expander generated code for handling
2537             --  shared passive partition access.
2538
2539             else
2540                pragma Assert
2541                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
2542
2543                --  Ada 2005 (AI-216): Program_Error is raised executing default
2544                --  implementation of the Input attribute of an unchecked union
2545                --  type if the type lacks default discriminant values.
2546
2547                if Is_Unchecked_Union (Base_Type (U_Type))
2548                  and then No (Discriminant_Constraint (U_Type))
2549                then
2550                   Insert_Action (N,
2551                     Make_Raise_Program_Error (Loc,
2552                       Reason => PE_Unchecked_Union_Restriction));
2553
2554                   return;
2555                end if;
2556
2557                --  Build the type's Input function, passing the subtype rather
2558                --  than its base type, because checks are needed in the case of
2559                --  constrained discriminants (see Ada 2012 AI05-0192).
2560
2561                Build_Record_Or_Elementary_Input_Function
2562                  (Loc, U_Type, Decl, Fname);
2563                Insert_Action (N, Decl);
2564
2565                if Nkind (Parent (N)) = N_Object_Declaration
2566                  and then Is_Record_Type (U_Type)
2567                then
2568                   --  The stream function may contain calls to user-defined
2569                   --  Read procedures for individual components.
2570
2571                   declare
2572                      Comp : Entity_Id;
2573                      Func : Entity_Id;
2574
2575                   begin
2576                      Comp := First_Component (U_Type);
2577                      while Present (Comp) loop
2578                         Func :=
2579                           Find_Stream_Subprogram
2580                             (Etype (Comp), TSS_Stream_Read);
2581
2582                         if Present (Func) then
2583                            Freeze_Stream_Subprogram (Func);
2584                         end if;
2585
2586                         Next_Component (Comp);
2587                      end loop;
2588                   end;
2589                end if;
2590             end if;
2591          end if;
2592
2593          --  If we fall through, Fname is the function to be called. The result
2594          --  is obtained by calling the appropriate function, then converting
2595          --  the result. The conversion does a subtype check.
2596
2597          Call :=
2598            Make_Function_Call (Loc,
2599              Name => New_Occurrence_Of (Fname, Loc),
2600              Parameter_Associations => New_List (
2601                 Relocate_Node (Strm)));
2602
2603          Set_Controlling_Argument (Call, Cntrl);
2604          Rewrite (N, Unchecked_Convert_To (P_Type, Call));
2605          Analyze_And_Resolve (N, P_Type);
2606
2607          if Nkind (Parent (N)) = N_Object_Declaration then
2608             Freeze_Stream_Subprogram (Fname);
2609          end if;
2610       end Input;
2611
2612       -------------------
2613       -- Integer_Value --
2614       -------------------
2615
2616       --  We transform
2617
2618       --    inttype'Fixed_Value (fixed-value)
2619
2620       --  into
2621
2622       --    inttype(integer-value))
2623
2624       --  we do all the required analysis of the conversion here, because we do
2625       --  not want this to go through the fixed-point conversion circuits. Note
2626       --  that the back end always treats fixed-point as equivalent to the
2627       --  corresponding integer type anyway.
2628
2629       when Attribute_Integer_Value => Integer_Value :
2630       begin
2631          Rewrite (N,
2632            Make_Type_Conversion (Loc,
2633              Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
2634              Expression   => Relocate_Node (First (Exprs))));
2635          Set_Etype (N, Entity (Pref));
2636          Set_Analyzed (N);
2637
2638       --  Note: it might appear that a properly analyzed unchecked conversion
2639       --  would be just fine here, but that's not the case, since the full
2640       --  range checks performed by the following call are critical!
2641
2642          Apply_Type_Conversion_Checks (N);
2643       end Integer_Value;
2644
2645       -------------------
2646       -- Invalid_Value --
2647       -------------------
2648
2649       when Attribute_Invalid_Value =>
2650          Rewrite (N, Get_Simple_Init_Val (Ptyp, N));
2651
2652       ----------
2653       -- Last --
2654       ----------
2655
2656       when Attribute_Last =>
2657
2658          --  If the prefix type is a constrained packed array type which
2659          --  already has a Packed_Array_Type representation defined, then
2660          --  replace this attribute with a direct reference to 'Last of the
2661          --  appropriate index subtype (since otherwise the back end will try
2662          --  to give us the value of 'Last for this implementation type).
2663
2664          if Is_Constrained_Packed_Array (Ptyp) then
2665             Rewrite (N,
2666               Make_Attribute_Reference (Loc,
2667                 Attribute_Name => Name_Last,
2668                 Prefix => New_Reference_To (Get_Index_Subtype (N), Loc)));
2669             Analyze_And_Resolve (N, Typ);
2670
2671          elsif Is_Access_Type (Ptyp) then
2672             Apply_Access_Check (N);
2673          end if;
2674
2675       --------------
2676       -- Last_Bit --
2677       --------------
2678
2679       --  We compute this if a component clause was present, otherwise we leave
2680       --  the computation up to the back end, since we don't know what layout
2681       --  will be chosen.
2682
2683       when Attribute_Last_Bit => Last_Bit : declare
2684          CE : constant Entity_Id := Entity (Selector_Name (Pref));
2685
2686       begin
2687          if Known_Static_Component_Bit_Offset (CE)
2688            and then Known_Static_Esize (CE)
2689          then
2690             Rewrite (N,
2691               Make_Integer_Literal (Loc,
2692                Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
2693                                 + Esize (CE) - 1));
2694
2695             Analyze_And_Resolve (N, Typ);
2696
2697          else
2698             Apply_Universal_Integer_Attribute_Checks (N);
2699          end if;
2700       end Last_Bit;
2701
2702       ------------------
2703       -- Leading_Part --
2704       ------------------
2705
2706       --  Transforms 'Leading_Part into a call to the floating-point attribute
2707       --  function Leading_Part in Fat_xxx (where xxx is the root type)
2708
2709       --  Note: strictly, we should generate special case code to deal with
2710       --  absurdly large positive arguments (greater than Integer'Last), which
2711       --  result in returning the first argument unchanged, but it hardly seems
2712       --  worth the effort. We raise constraint error for absurdly negative
2713       --  arguments which is fine.
2714
2715       when Attribute_Leading_Part =>
2716          Expand_Fpt_Attribute_RI (N);
2717
2718       ------------
2719       -- Length --
2720       ------------
2721
2722       when Attribute_Length => declare
2723          Ityp : Entity_Id;
2724          Xnum : Uint;
2725
2726       begin
2727          --  Processing for packed array types
2728
2729          if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
2730             Ityp := Get_Index_Subtype (N);
2731
2732             --  If the index type, Ityp, is an enumeration type with holes,
2733             --  then we calculate X'Length explicitly using
2734
2735             --     Typ'Max
2736             --       (0, Ityp'Pos (X'Last  (N)) -
2737             --           Ityp'Pos (X'First (N)) + 1);
2738
2739             --  Since the bounds in the template are the representation values
2740             --  and the back end would get the wrong value.
2741
2742             if Is_Enumeration_Type (Ityp)
2743               and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
2744             then
2745                if No (Exprs) then
2746                   Xnum := Uint_1;
2747                else
2748                   Xnum := Expr_Value (First (Expressions (N)));
2749                end if;
2750
2751                Rewrite (N,
2752                  Make_Attribute_Reference (Loc,
2753                    Prefix         => New_Occurrence_Of (Typ, Loc),
2754                    Attribute_Name => Name_Max,
2755                    Expressions    => New_List
2756                      (Make_Integer_Literal (Loc, 0),
2757
2758                       Make_Op_Add (Loc,
2759                         Left_Opnd =>
2760                           Make_Op_Subtract (Loc,
2761                             Left_Opnd =>
2762                               Make_Attribute_Reference (Loc,
2763                                 Prefix => New_Occurrence_Of (Ityp, Loc),
2764                                 Attribute_Name => Name_Pos,
2765
2766                                 Expressions => New_List (
2767                                   Make_Attribute_Reference (Loc,
2768                                     Prefix => Duplicate_Subexpr (Pref),
2769                                    Attribute_Name => Name_Last,
2770                                     Expressions => New_List (
2771                                       Make_Integer_Literal (Loc, Xnum))))),
2772
2773                             Right_Opnd =>
2774                               Make_Attribute_Reference (Loc,
2775                                 Prefix => New_Occurrence_Of (Ityp, Loc),
2776                                 Attribute_Name => Name_Pos,
2777
2778                                 Expressions => New_List (
2779                                   Make_Attribute_Reference (Loc,
2780                                     Prefix =>
2781                                       Duplicate_Subexpr_No_Checks (Pref),
2782                                    Attribute_Name => Name_First,
2783                                     Expressions => New_List (
2784                                       Make_Integer_Literal (Loc, Xnum)))))),
2785
2786                         Right_Opnd => Make_Integer_Literal (Loc, 1)))));
2787
2788                Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
2789                return;
2790
2791             --  If the prefix type is a constrained packed array type which
2792             --  already has a Packed_Array_Type representation defined, then
2793             --  replace this attribute with a direct reference to 'Range_Length
2794             --  of the appropriate index subtype (since otherwise the back end
2795             --  will try to give us the value of 'Length for this
2796             --  implementation type).
2797
2798             elsif Is_Constrained (Ptyp) then
2799                Rewrite (N,
2800                  Make_Attribute_Reference (Loc,
2801                    Attribute_Name => Name_Range_Length,
2802                    Prefix => New_Reference_To (Ityp, Loc)));
2803                Analyze_And_Resolve (N, Typ);
2804             end if;
2805
2806          --  Access type case
2807
2808          elsif Is_Access_Type (Ptyp) then
2809             Apply_Access_Check (N);
2810
2811             --  If the designated type is a packed array type, then we convert
2812             --  the reference to:
2813
2814             --    typ'Max (0, 1 +
2815             --                xtyp'Pos (Pref'Last (Expr)) -
2816             --                xtyp'Pos (Pref'First (Expr)));
2817
2818             --  This is a bit complex, but it is the easiest thing to do that
2819             --  works in all cases including enum types with holes xtyp here
2820             --  is the appropriate index type.
2821
2822             declare
2823                Dtyp : constant Entity_Id := Designated_Type (Ptyp);
2824                Xtyp : Entity_Id;
2825
2826             begin
2827                if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
2828                   Xtyp := Get_Index_Subtype (N);
2829
2830                   Rewrite (N,
2831                     Make_Attribute_Reference (Loc,
2832                       Prefix         => New_Occurrence_Of (Typ, Loc),
2833                       Attribute_Name => Name_Max,
2834                       Expressions    => New_List (
2835                         Make_Integer_Literal (Loc, 0),
2836
2837                         Make_Op_Add (Loc,
2838                           Make_Integer_Literal (Loc, 1),
2839                           Make_Op_Subtract (Loc,
2840                             Left_Opnd =>
2841                               Make_Attribute_Reference (Loc,
2842                                 Prefix => New_Occurrence_Of (Xtyp, Loc),
2843                                 Attribute_Name => Name_Pos,
2844                                 Expressions    => New_List (
2845                                   Make_Attribute_Reference (Loc,
2846                                     Prefix => Duplicate_Subexpr (Pref),
2847                                     Attribute_Name => Name_Last,
2848                                     Expressions =>
2849                                       New_Copy_List (Exprs)))),
2850
2851                             Right_Opnd =>
2852                               Make_Attribute_Reference (Loc,
2853                                 Prefix => New_Occurrence_Of (Xtyp, Loc),
2854                                 Attribute_Name => Name_Pos,
2855                                 Expressions    => New_List (
2856                                   Make_Attribute_Reference (Loc,
2857                                     Prefix =>
2858                                       Duplicate_Subexpr_No_Checks (Pref),
2859                                     Attribute_Name => Name_First,
2860                                     Expressions =>
2861                                       New_Copy_List (Exprs)))))))));
2862
2863                   Analyze_And_Resolve (N, Typ);
2864                end if;
2865             end;
2866
2867          --  Otherwise leave it to the back end
2868
2869          else
2870             Apply_Universal_Integer_Attribute_Checks (N);
2871          end if;
2872       end;
2873
2874       -------------
2875       -- Machine --
2876       -------------
2877
2878       --  Transforms 'Machine into a call to the floating-point attribute
2879       --  function Machine in Fat_xxx (where xxx is the root type)
2880
2881       when Attribute_Machine =>
2882          Expand_Fpt_Attribute_R (N);
2883
2884       ----------------------
2885       -- Machine_Rounding --
2886       ----------------------
2887
2888       --  Transforms 'Machine_Rounding into a call to the floating-point
2889       --  attribute function Machine_Rounding in Fat_xxx (where xxx is the root
2890       --  type). Expansion is avoided for cases the back end can handle
2891       --  directly.
2892
2893       when Attribute_Machine_Rounding =>
2894          if not Is_Inline_Floating_Point_Attribute (N) then
2895             Expand_Fpt_Attribute_R (N);
2896          end if;
2897
2898       ------------------
2899       -- Machine_Size --
2900       ------------------
2901
2902       --  Machine_Size is equivalent to Object_Size, so transform it into
2903       --  Object_Size and that way the back end never sees Machine_Size.
2904
2905       when Attribute_Machine_Size =>
2906          Rewrite (N,
2907            Make_Attribute_Reference (Loc,
2908              Prefix => Prefix (N),
2909              Attribute_Name => Name_Object_Size));
2910
2911          Analyze_And_Resolve (N, Typ);
2912
2913       --------------
2914       -- Mantissa --
2915       --------------
2916
2917       --  The only case that can get this far is the dynamic case of the old
2918       --  Ada 83 Mantissa attribute for the fixed-point case. For this case,
2919       --  we expand:
2920
2921       --    typ'Mantissa
2922
2923       --  into
2924
2925       --    ityp (System.Mantissa.Mantissa_Value
2926       --           (Integer'Integer_Value (typ'First),
2927       --            Integer'Integer_Value (typ'Last)));
2928
2929       when Attribute_Mantissa => Mantissa : begin
2930          Rewrite (N,
2931            Convert_To (Typ,
2932              Make_Function_Call (Loc,
2933                Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
2934
2935                Parameter_Associations => New_List (
2936
2937                  Make_Attribute_Reference (Loc,
2938                    Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2939                    Attribute_Name => Name_Integer_Value,
2940                    Expressions => New_List (
2941
2942                      Make_Attribute_Reference (Loc,
2943                        Prefix => New_Occurrence_Of (Ptyp, Loc),
2944                        Attribute_Name => Name_First))),
2945
2946                  Make_Attribute_Reference (Loc,
2947                    Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2948                    Attribute_Name => Name_Integer_Value,
2949                    Expressions => New_List (
2950
2951                      Make_Attribute_Reference (Loc,
2952                        Prefix => New_Occurrence_Of (Ptyp, Loc),
2953                        Attribute_Name => Name_Last)))))));
2954
2955          Analyze_And_Resolve (N, Typ);
2956       end Mantissa;
2957
2958       --------------------
2959       -- Mechanism_Code --
2960       --------------------
2961
2962       when Attribute_Mechanism_Code =>
2963
2964          --  We must replace the prefix in the renamed case
2965
2966          if Is_Entity_Name (Pref)
2967            and then Present (Alias (Entity (Pref)))
2968          then
2969             Set_Renamed_Subprogram (Pref, Alias (Entity (Pref)));
2970          end if;
2971
2972       ---------
2973       -- Mod --
2974       ---------
2975
2976       when Attribute_Mod => Mod_Case : declare
2977          Arg  : constant Node_Id := Relocate_Node (First (Exprs));
2978          Hi   : constant Node_Id := Type_High_Bound (Etype (Arg));
2979          Modv : constant Uint    := Modulus (Btyp);
2980
2981       begin
2982
2983          --  This is not so simple. The issue is what type to use for the
2984          --  computation of the modular value.
2985
2986          --  The easy case is when the modulus value is within the bounds
2987          --  of the signed integer type of the argument. In this case we can
2988          --  just do the computation in that signed integer type, and then
2989          --  do an ordinary conversion to the target type.
2990
2991          if Modv <= Expr_Value (Hi) then
2992             Rewrite (N,
2993               Convert_To (Btyp,
2994                 Make_Op_Mod (Loc,
2995                   Left_Opnd  => Arg,
2996                   Right_Opnd => Make_Integer_Literal (Loc, Modv))));
2997
2998          --  Here we know that the modulus is larger than type'Last of the
2999          --  integer type. There are two cases to consider:
3000
3001          --    a) The integer value is non-negative. In this case, it is
3002          --    returned as the result (since it is less than the modulus).
3003
3004          --    b) The integer value is negative. In this case, we know that the
3005          --    result is modulus + value, where the value might be as small as
3006          --    -modulus. The trouble is what type do we use to do the subtract.
3007          --    No type will do, since modulus can be as big as 2**64, and no
3008          --    integer type accommodates this value. Let's do bit of algebra
3009
3010          --         modulus + value
3011          --      =  modulus - (-value)
3012          --      =  (modulus - 1) - (-value - 1)
3013
3014          --    Now modulus - 1 is certainly in range of the modular type.
3015          --    -value is in the range 1 .. modulus, so -value -1 is in the
3016          --    range 0 .. modulus-1 which is in range of the modular type.
3017          --    Furthermore, (-value - 1) can be expressed as -(value + 1)
3018          --    which we can compute using the integer base type.
3019
3020          --  Once this is done we analyze the conditional expression without
3021          --  range checks, because we know everything is in range, and we
3022          --  want to prevent spurious warnings on either branch.
3023
3024          else
3025             Rewrite (N,
3026               Make_Conditional_Expression (Loc,
3027                 Expressions => New_List (
3028                   Make_Op_Ge (Loc,
3029                     Left_Opnd  => Duplicate_Subexpr (Arg),
3030                     Right_Opnd => Make_Integer_Literal (Loc, 0)),
3031
3032                   Convert_To (Btyp,
3033                     Duplicate_Subexpr_No_Checks (Arg)),
3034
3035                   Make_Op_Subtract (Loc,
3036                     Left_Opnd =>
3037                       Make_Integer_Literal (Loc,
3038                         Intval => Modv - 1),
3039                     Right_Opnd =>
3040                       Convert_To (Btyp,
3041                         Make_Op_Minus (Loc,
3042                           Right_Opnd =>
3043                             Make_Op_Add (Loc,
3044                               Left_Opnd  => Duplicate_Subexpr_No_Checks (Arg),
3045                               Right_Opnd =>
3046                                 Make_Integer_Literal (Loc,
3047                                   Intval => 1))))))));
3048
3049          end if;
3050
3051          Analyze_And_Resolve (N, Btyp, Suppress => All_Checks);
3052       end Mod_Case;
3053
3054       -----------
3055       -- Model --
3056       -----------
3057
3058       --  Transforms 'Model into a call to the floating-point attribute
3059       --  function Model in Fat_xxx (where xxx is the root type)
3060
3061       when Attribute_Model =>
3062          Expand_Fpt_Attribute_R (N);
3063
3064       -----------------
3065       -- Object_Size --
3066       -----------------
3067
3068       --  The processing for Object_Size shares the processing for Size
3069
3070       ---------
3071       -- Old --
3072       ---------
3073
3074       when Attribute_Old => Old : declare
3075          Tnn     : constant Entity_Id := Make_Temporary (Loc, 'T', Pref);
3076          Subp    : Node_Id;
3077          Asn_Stm : Node_Id;
3078
3079       begin
3080          --  Find the nearest subprogram body, ignoring _Preconditions
3081
3082          Subp := N;
3083          loop
3084             Subp := Parent (Subp);
3085             exit when Nkind (Subp) = N_Subprogram_Body
3086               and then Chars (Defining_Entity (Subp)) /= Name_uPostconditions;
3087          end loop;
3088
3089          --  Insert the initialized object declaration at the start of the
3090          --  subprogram's declarations.
3091
3092          Asn_Stm :=
3093            Make_Object_Declaration (Loc,
3094              Defining_Identifier => Tnn,
3095              Constant_Present    => True,
3096              Object_Definition   => New_Occurrence_Of (Etype (N), Loc),
3097              Expression          => Pref);
3098
3099          --  Push the subprogram's scope, so that the object will be analyzed
3100          --  in that context (rather than the context of the Precondition
3101          --  subprogram) and will have its Scope set properly.
3102
3103          if Present (Corresponding_Spec (Subp)) then
3104             Push_Scope (Corresponding_Spec (Subp));
3105          else
3106             Push_Scope (Defining_Entity (Subp));
3107          end if;
3108
3109          if Is_Empty_List (Declarations (Subp)) then
3110             Set_Declarations (Subp, New_List (Asn_Stm));
3111             Analyze (Asn_Stm);
3112          else
3113             Insert_Action (First (Declarations (Subp)), Asn_Stm);
3114          end if;
3115
3116          Pop_Scope;
3117
3118          Rewrite (N, New_Occurrence_Of (Tnn, Loc));
3119       end Old;
3120
3121       ----------------------
3122       -- Overlaps_Storage --
3123       ----------------------
3124
3125       when Attribute_Overlaps_Storage => Overlaps_Storage : declare
3126          Loc : constant Source_Ptr := Sloc (N);
3127
3128          X   : constant Node_Id := Prefix (N);
3129          Y   : constant Node_Id := First (Expressions (N));
3130          --  The argumens
3131
3132          X_Addr, Y_Addr : Node_Id;
3133          --  the expressions for their integer addresses
3134
3135          X_Size, Y_Size : Node_Id;
3136          --  the expressions for their sizes
3137
3138          Cond : Node_Id;
3139
3140       begin
3141          --  Attribute expands into:
3142
3143          --    if X'Address < Y'address then
3144          --      (X'address + X'Size - 1) >= Y'address
3145          --    else
3146          --      (Y'address + Y'size - 1) >= X'Address
3147          --    end if;
3148
3149          --  with the proper address operations. We convert addresses to
3150          --  integer addresses to use predefined arithmetic. The size is
3151          --  expressed in storage units.
3152
3153          X_Addr :=
3154            Unchecked_Convert_To (RTE (RE_Integer_Address),
3155              Make_Attribute_Reference (Loc,
3156                Attribute_Name => Name_Address,
3157                Prefix         => New_Copy_Tree (X)));
3158
3159          Y_Addr :=
3160            Unchecked_Convert_To (RTE (RE_Integer_Address),
3161              Make_Attribute_Reference (Loc,
3162                Attribute_Name => Name_Address,
3163                Prefix         => New_Copy_Tree (Y)));
3164
3165          X_Size :=
3166            Make_Op_Divide (Loc,
3167              Left_Opnd  =>
3168                Make_Attribute_Reference (Loc,
3169                  Attribute_Name => Name_Size,
3170                  Prefix         => New_Copy_Tree (X)),
3171              Right_Opnd =>
3172                Make_Integer_Literal (Loc, System_Storage_Unit));
3173
3174          Y_Size :=
3175            Make_Op_Divide (Loc,
3176              Left_Opnd  =>
3177                Make_Attribute_Reference (Loc,
3178                  Attribute_Name => Name_Size,
3179                  Prefix         => New_Copy_Tree (Y)),
3180              Right_Opnd =>
3181                Make_Integer_Literal (Loc, System_Storage_Unit));
3182
3183          Cond :=
3184             Make_Op_Le (Loc,
3185               Left_Opnd  => X_Addr,
3186               Right_Opnd => Y_Addr);
3187
3188          Rewrite (N,
3189            Make_Conditional_Expression (Loc,
3190              New_List (
3191                Cond,
3192
3193                Make_Op_Ge (Loc,
3194                   Left_Opnd   =>
3195                    Make_Op_Add (Loc,
3196                      Left_Opnd  => X_Addr,
3197                      Right_Opnd =>
3198                        Make_Op_Subtract (Loc,
3199                          Left_Opnd  => X_Size,
3200                          Right_Opnd => Make_Integer_Literal (Loc, 1))),
3201                   Right_Opnd => Y_Addr),
3202
3203                Make_Op_Ge (Loc,
3204                    Make_Op_Add (Loc,
3205                      Left_Opnd  => Y_Addr,
3206                      Right_Opnd =>
3207                        Make_Op_Subtract (Loc,
3208                          Left_Opnd  => Y_Size,
3209                          Right_Opnd => Make_Integer_Literal (Loc, 1))),
3210                   Right_Opnd => X_Addr))));
3211
3212          Analyze_And_Resolve (N, Standard_Boolean);
3213       end Overlaps_Storage;
3214
3215       ------------
3216       -- Output --
3217       ------------
3218
3219       when Attribute_Output => Output : declare
3220          P_Type : constant Entity_Id := Entity (Pref);
3221          U_Type : constant Entity_Id := Underlying_Type (P_Type);
3222          Pname  : Entity_Id;
3223          Decl   : Node_Id;
3224          Prag   : Node_Id;
3225          Arg3   : Node_Id;
3226          Wfunc  : Node_Id;
3227
3228       begin
3229          --  If no underlying type, we have an error that will be diagnosed
3230          --  elsewhere, so here we just completely ignore the expansion.
3231
3232          if No (U_Type) then
3233             return;
3234          end if;
3235
3236          --  If TSS for Output is present, just call it
3237
3238          Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
3239
3240          if Present (Pname) then
3241             null;
3242
3243          else
3244             --  If there is a Stream_Convert pragma, use it, we rewrite
3245
3246             --     sourcetyp'Output (stream, Item)
3247
3248             --  as
3249
3250             --     strmtyp'Output (Stream, strmwrite (acttyp (Item)));
3251
3252             --  where strmwrite is the given Write function that converts an
3253             --  argument of type sourcetyp or a type acctyp, from which it is
3254             --  derived to type strmtyp. The conversion to acttyp is required
3255             --  for the derived case.
3256
3257             Prag := Get_Stream_Convert_Pragma (P_Type);
3258
3259             if Present (Prag) then
3260                Arg3 :=
3261                  Next (Next (First (Pragma_Argument_Associations (Prag))));
3262                Wfunc := Entity (Expression (Arg3));
3263
3264                Rewrite (N,
3265                  Make_Attribute_Reference (Loc,
3266                    Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
3267                    Attribute_Name => Name_Output,
3268                    Expressions => New_List (
3269                    Relocate_Node (First (Exprs)),
3270                      Make_Function_Call (Loc,
3271                        Name => New_Occurrence_Of (Wfunc, Loc),
3272                        Parameter_Associations => New_List (
3273                          OK_Convert_To (Etype (First_Formal (Wfunc)),
3274                            Relocate_Node (Next (First (Exprs)))))))));
3275
3276                Analyze (N);
3277                return;
3278
3279             --  For elementary types, we call the W_xxx routine directly.
3280             --  Note that the effect of Write and Output is identical for
3281             --  the case of an elementary type, since there are no
3282             --  discriminants or bounds.
3283
3284             elsif Is_Elementary_Type (U_Type) then
3285
3286                --  A special case arises if we have a defined _Write routine,
3287                --  since in this case we are required to call this routine.
3288
3289                if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then
3290                   Build_Record_Or_Elementary_Output_Procedure
3291                     (Loc, U_Type, Decl, Pname);
3292                   Insert_Action (N, Decl);
3293
3294                --  For normal cases, we call the W_xxx routine directly
3295
3296                else
3297                   Rewrite (N, Build_Elementary_Write_Call (N));
3298                   Analyze (N);
3299                   return;
3300                end if;
3301
3302             --  Array type case
3303
3304             elsif Is_Array_Type (U_Type) then
3305                Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
3306                Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3307
3308             --  Class-wide case, first output external tag, then dispatch
3309             --  to the appropriate primitive Output function (RM 13.13.2(31)).
3310
3311             elsif Is_Class_Wide_Type (P_Type) then
3312
3313                --  No need to do anything else compiling under restriction
3314                --  No_Dispatching_Calls. During the semantic analysis we
3315                --  already notified such violation.
3316
3317                if Restriction_Active (No_Dispatching_Calls) then
3318                   return;
3319                end if;
3320
3321                Tag_Write : declare
3322                   Strm : constant Node_Id := First (Exprs);
3323                   Item : constant Node_Id := Next (Strm);
3324
3325                begin
3326                   --  Ada 2005 (AI-344): Check that the accessibility level
3327                   --  of the type of the output object is not deeper than
3328                   --  that of the attribute's prefix type.
3329
3330                   --  if Get_Access_Level (Item'Tag)
3331                   --       /= Get_Access_Level (P_Type'Tag)
3332                   --  then
3333                   --     raise Tag_Error;
3334                   --  end if;
3335
3336                   --  String'Output (Strm, External_Tag (Item'Tag));
3337
3338                   --  We cannot figure out a practical way to implement this
3339                   --  accessibility check on virtual machines, so we omit it.
3340
3341                   if Ada_Version >= Ada_2005
3342                     and then Tagged_Type_Expansion
3343                   then
3344                      Insert_Action (N,
3345                        Make_Implicit_If_Statement (N,
3346                          Condition =>
3347                            Make_Op_Ne (Loc,
3348                              Left_Opnd  =>
3349                                Build_Get_Access_Level (Loc,
3350                                  Make_Attribute_Reference (Loc,
3351                                    Prefix         =>
3352                                      Relocate_Node (
3353                                        Duplicate_Subexpr (Item,
3354                                          Name_Req => True)),
3355                                    Attribute_Name => Name_Tag)),
3356
3357                              Right_Opnd =>
3358                                Make_Integer_Literal (Loc,
3359                                  Type_Access_Level (P_Type))),
3360
3361                          Then_Statements =>
3362                            New_List (Make_Raise_Statement (Loc,
3363                                        New_Occurrence_Of (
3364                                          RTE (RE_Tag_Error), Loc)))));
3365                   end if;
3366
3367                   Insert_Action (N,
3368                     Make_Attribute_Reference (Loc,
3369                       Prefix => New_Occurrence_Of (Standard_String, Loc),
3370                       Attribute_Name => Name_Output,
3371                       Expressions => New_List (
3372                         Relocate_Node (Duplicate_Subexpr (Strm)),
3373                         Make_Function_Call (Loc,
3374                           Name =>
3375                             New_Occurrence_Of (RTE (RE_External_Tag), Loc),
3376                           Parameter_Associations => New_List (
3377                            Make_Attribute_Reference (Loc,
3378                              Prefix =>
3379                                Relocate_Node
3380                                  (Duplicate_Subexpr (Item, Name_Req => True)),
3381                              Attribute_Name => Name_Tag))))));
3382                end Tag_Write;
3383
3384                Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
3385
3386             --  Tagged type case, use the primitive Output function
3387
3388             elsif Is_Tagged_Type (U_Type) then
3389                Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
3390
3391             --  All other record type cases, including protected records.
3392             --  The latter only arise for expander generated code for
3393             --  handling shared passive partition access.
3394
3395             else
3396                pragma Assert
3397                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
3398
3399                --  Ada 2005 (AI-216): Program_Error is raised when executing
3400                --  the default implementation of the Output attribute of an
3401                --  unchecked union type if the type lacks default discriminant
3402                --  values.
3403
3404                if Is_Unchecked_Union (Base_Type (U_Type))
3405                  and then No (Discriminant_Constraint (U_Type))
3406                then
3407                   Insert_Action (N,
3408                     Make_Raise_Program_Error (Loc,
3409                       Reason => PE_Unchecked_Union_Restriction));
3410
3411                   return;
3412                end if;
3413
3414                Build_Record_Or_Elementary_Output_Procedure
3415                  (Loc, Base_Type (U_Type), Decl, Pname);
3416                Insert_Action (N, Decl);
3417             end if;
3418          end if;
3419
3420          --  If we fall through, Pname is the name of the procedure to call
3421
3422          Rewrite_Stream_Proc_Call (Pname);
3423       end Output;
3424
3425       ---------
3426       -- Pos --
3427       ---------
3428
3429       --  For enumeration types with a standard representation, Pos is
3430       --  handled by the back end.
3431
3432       --  For enumeration types, with a non-standard representation we generate
3433       --  a call to the _Rep_To_Pos function created when the type was frozen.
3434       --  The call has the form
3435
3436       --    _rep_to_pos (expr, flag)
3437
3438       --  The parameter flag is True if range checks are enabled, causing
3439       --  Program_Error to be raised if the expression has an invalid
3440       --  representation, and False if range checks are suppressed.
3441
3442       --  For integer types, Pos is equivalent to a simple integer
3443       --  conversion and we rewrite it as such
3444
3445       when Attribute_Pos => Pos :
3446       declare
3447          Etyp : Entity_Id := Base_Type (Entity (Pref));
3448
3449       begin
3450          --  Deal with zero/non-zero boolean values
3451
3452          if Is_Boolean_Type (Etyp) then
3453             Adjust_Condition (First (Exprs));
3454             Etyp := Standard_Boolean;
3455             Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
3456          end if;
3457
3458          --  Case of enumeration type
3459
3460          if Is_Enumeration_Type (Etyp) then
3461
3462             --  Non-standard enumeration type (generate call)
3463
3464             if Present (Enum_Pos_To_Rep (Etyp)) then
3465                Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
3466                Rewrite (N,
3467                  Convert_To (Typ,
3468                    Make_Function_Call (Loc,
3469                      Name =>
3470                        New_Reference_To (TSS (Etyp, TSS_Rep_To_Pos), Loc),
3471                      Parameter_Associations => Exprs)));
3472
3473                Analyze_And_Resolve (N, Typ);
3474
3475             --  Standard enumeration type (do universal integer check)
3476
3477             else
3478                Apply_Universal_Integer_Attribute_Checks (N);
3479             end if;
3480
3481          --  Deal with integer types (replace by conversion)
3482
3483          elsif Is_Integer_Type (Etyp) then
3484             Rewrite (N, Convert_To (Typ, First (Exprs)));
3485             Analyze_And_Resolve (N, Typ);
3486          end if;
3487
3488       end Pos;
3489
3490       --------------
3491       -- Position --
3492       --------------
3493
3494       --  We compute this if a component clause was present, otherwise we leave
3495       --  the computation up to the back end, since we don't know what layout
3496       --  will be chosen.
3497
3498       when Attribute_Position => Position :
3499       declare
3500          CE : constant Entity_Id := Entity (Selector_Name (Pref));
3501
3502       begin
3503          if Present (Component_Clause (CE)) then
3504             Rewrite (N,
3505               Make_Integer_Literal (Loc,
3506                 Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
3507             Analyze_And_Resolve (N, Typ);
3508
3509          else
3510             Apply_Universal_Integer_Attribute_Checks (N);
3511          end if;
3512       end Position;
3513
3514       ----------
3515       -- Pred --
3516       ----------
3517
3518       --  1. Deal with enumeration types with holes
3519       --  2. For floating-point, generate call to attribute function
3520       --  3. For other cases, deal with constraint checking
3521
3522       when Attribute_Pred => Pred :
3523       declare
3524          Etyp : constant Entity_Id := Base_Type (Ptyp);
3525
3526       begin
3527
3528          --  For enumeration types with non-standard representations, we
3529          --  expand typ'Pred (x) into
3530
3531          --    Pos_To_Rep (Rep_To_Pos (x) - 1)
3532
3533          --    If the representation is contiguous, we compute instead
3534          --    Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
3535          --    The conversion function Enum_Pos_To_Rep is defined on the
3536          --    base type, not the subtype, so we have to use the base type
3537          --    explicitly for this and other enumeration attributes.
3538
3539          if Is_Enumeration_Type (Ptyp)
3540            and then Present (Enum_Pos_To_Rep (Etyp))
3541          then
3542             if Has_Contiguous_Rep (Etyp) then
3543                Rewrite (N,
3544                   Unchecked_Convert_To (Ptyp,
3545                      Make_Op_Add (Loc,
3546                         Left_Opnd  =>
3547                          Make_Integer_Literal (Loc,
3548                            Enumeration_Rep (First_Literal (Ptyp))),
3549                         Right_Opnd =>
3550                           Make_Function_Call (Loc,
3551                             Name =>
3552                               New_Reference_To
3553                                (TSS (Etyp, TSS_Rep_To_Pos), Loc),
3554
3555                             Parameter_Associations =>
3556                               New_List (
3557                                 Unchecked_Convert_To (Ptyp,
3558                                   Make_Op_Subtract (Loc,
3559                                     Left_Opnd =>
3560                                      Unchecked_Convert_To (Standard_Integer,
3561                                        Relocate_Node (First (Exprs))),
3562                                     Right_Opnd =>
3563                                       Make_Integer_Literal (Loc, 1))),
3564                                 Rep_To_Pos_Flag (Ptyp, Loc))))));
3565
3566             else
3567                --  Add Boolean parameter True, to request program errror if
3568                --  we have a bad representation on our hands. If checks are
3569                --  suppressed, then add False instead
3570
3571                Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
3572                Rewrite (N,
3573                  Make_Indexed_Component (Loc,
3574                    Prefix =>
3575                      New_Reference_To
3576                        (Enum_Pos_To_Rep (Etyp), Loc),
3577                    Expressions => New_List (
3578                      Make_Op_Subtract (Loc,
3579                     Left_Opnd =>
3580                       Make_Function_Call (Loc,
3581                         Name =>
3582                           New_Reference_To
3583                             (TSS (Etyp, TSS_Rep_To_Pos), Loc),
3584                           Parameter_Associations => Exprs),
3585                     Right_Opnd => Make_Integer_Literal (Loc, 1)))));
3586             end if;
3587
3588             Analyze_And_Resolve (N, Typ);
3589
3590          --  For floating-point, we transform 'Pred into a call to the Pred
3591          --  floating-point attribute function in Fat_xxx (xxx is root type)
3592
3593          elsif Is_Floating_Point_Type (Ptyp) then
3594             Expand_Fpt_Attribute_R (N);
3595             Analyze_And_Resolve (N, Typ);
3596
3597          --  For modular types, nothing to do (no overflow, since wraps)
3598
3599          elsif Is_Modular_Integer_Type (Ptyp) then
3600             null;
3601
3602          --  For other types, if argument is marked as needing a range check or
3603          --  overflow checking is enabled, we must generate a check.
3604
3605          elsif not Overflow_Checks_Suppressed (Ptyp)
3606            or else Do_Range_Check (First (Exprs))
3607          then
3608             Set_Do_Range_Check (First (Exprs), False);
3609             Expand_Pred_Succ (N);
3610          end if;
3611       end Pred;
3612
3613       --------------
3614       -- Priority --
3615       --------------
3616
3617       --  Ada 2005 (AI-327): Dynamic ceiling priorities
3618
3619       --  We rewrite X'Priority as the following run-time call:
3620
3621       --     Get_Ceiling (X._Object)
3622
3623       --  Note that although X'Priority is notionally an object, it is quite
3624       --  deliberately not defined as an aliased object in the RM. This means
3625       --  that it works fine to rewrite it as a call, without having to worry
3626       --  about complications that would other arise from X'Priority'Access,
3627       --  which is illegal, because of the lack of aliasing.
3628
3629       when Attribute_Priority =>
3630          declare
3631             Call           : Node_Id;
3632             Conctyp        : Entity_Id;
3633             Object_Parm    : Node_Id;
3634             Subprg         : Entity_Id;
3635             RT_Subprg_Name : Node_Id;
3636
3637          begin
3638             --  Look for the enclosing concurrent type
3639
3640             Conctyp := Current_Scope;
3641             while not Is_Concurrent_Type (Conctyp) loop
3642                Conctyp := Scope (Conctyp);
3643             end loop;
3644
3645             pragma Assert (Is_Protected_Type (Conctyp));
3646
3647             --  Generate the actual of the call
3648
3649             Subprg := Current_Scope;
3650             while not Present (Protected_Body_Subprogram (Subprg)) loop
3651                Subprg := Scope (Subprg);
3652             end loop;
3653
3654             --  Use of 'Priority inside protected entries and barriers (in
3655             --  both cases the type of the first formal of their expanded
3656             --  subprogram is Address)
3657
3658             if Etype (First_Entity (Protected_Body_Subprogram (Subprg)))
3659               = RTE (RE_Address)
3660             then
3661                declare
3662                   New_Itype : Entity_Id;
3663
3664                begin
3665                   --  In the expansion of protected entries the type of the
3666                   --  first formal of the Protected_Body_Subprogram is an
3667                   --  Address. In order to reference the _object component
3668                   --  we generate:
3669
3670                   --    type T is access p__ptTV;
3671                   --    freeze T []
3672
3673                   New_Itype := Create_Itype (E_Access_Type, N);
3674                   Set_Etype (New_Itype, New_Itype);
3675                   Set_Directly_Designated_Type (New_Itype,
3676                     Corresponding_Record_Type (Conctyp));
3677                   Freeze_Itype (New_Itype, N);
3678
3679                   --  Generate:
3680                   --    T!(O)._object'unchecked_access
3681
3682                   Object_Parm :=
3683                     Make_Attribute_Reference (Loc,
3684                       Prefix =>
3685                         Make_Selected_Component (Loc,
3686                           Prefix =>
3687                             Unchecked_Convert_To (New_Itype,
3688                               New_Reference_To
3689                                 (First_Entity
3690                                   (Protected_Body_Subprogram (Subprg)),
3691                                  Loc)),
3692                           Selector_Name =>
3693                             Make_Identifier (Loc, Name_uObject)),
3694                        Attribute_Name => Name_Unchecked_Access);
3695                end;
3696
3697             --  Use of 'Priority inside a protected subprogram
3698
3699             else
3700                Object_Parm :=
3701                  Make_Attribute_Reference (Loc,
3702                     Prefix =>
3703                       Make_Selected_Component (Loc,
3704                         Prefix => New_Reference_To
3705                                     (First_Entity
3706                                       (Protected_Body_Subprogram (Subprg)),
3707                                        Loc),
3708                         Selector_Name => Make_Identifier (Loc, Name_uObject)),
3709                     Attribute_Name => Name_Unchecked_Access);
3710             end if;
3711
3712             --  Select the appropriate run-time subprogram
3713
3714             if Number_Entries (Conctyp) = 0 then
3715                RT_Subprg_Name :=
3716                  New_Reference_To (RTE (RE_Get_Ceiling), Loc);
3717             else
3718                RT_Subprg_Name :=
3719                  New_Reference_To (RTE (RO_PE_Get_Ceiling), Loc);
3720             end if;
3721
3722             Call :=
3723               Make_Function_Call (Loc,
3724                 Name => RT_Subprg_Name,
3725                 Parameter_Associations => New_List (Object_Parm));
3726
3727             Rewrite (N, Call);
3728
3729             --  Avoid the generation of extra checks on the pointer to the
3730             --  protected object.
3731
3732             Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
3733          end;
3734
3735       ------------------
3736       -- Range_Length --
3737       ------------------
3738
3739       when Attribute_Range_Length => Range_Length : begin
3740
3741          --  The only special processing required is for the case where
3742          --  Range_Length is applied to an enumeration type with holes.
3743          --  In this case we transform
3744
3745          --     X'Range_Length
3746
3747          --  to
3748
3749          --     X'Pos (X'Last) - X'Pos (X'First) + 1
3750
3751          --  So that the result reflects the proper Pos values instead
3752          --  of the underlying representations.
3753
3754          if Is_Enumeration_Type (Ptyp)
3755            and then Has_Non_Standard_Rep (Ptyp)
3756          then
3757             Rewrite (N,
3758               Make_Op_Add (Loc,
3759                 Left_Opnd =>
3760                   Make_Op_Subtract (Loc,
3761                     Left_Opnd =>
3762                       Make_Attribute_Reference (Loc,
3763                         Attribute_Name => Name_Pos,
3764                         Prefix => New_Occurrence_Of (Ptyp, Loc),
3765                         Expressions => New_List (
3766                           Make_Attribute_Reference (Loc,
3767                             Attribute_Name => Name_Last,
3768                             Prefix => New_Occurrence_Of (Ptyp, Loc)))),
3769
3770                     Right_Opnd =>
3771                       Make_Attribute_Reference (Loc,
3772                         Attribute_Name => Name_Pos,
3773                         Prefix => New_Occurrence_Of (Ptyp, Loc),
3774                         Expressions => New_List (
3775                           Make_Attribute_Reference (Loc,
3776                             Attribute_Name => Name_First,
3777                             Prefix => New_Occurrence_Of (Ptyp, Loc))))),
3778
3779                 Right_Opnd => Make_Integer_Literal (Loc, 1)));
3780
3781             Analyze_And_Resolve (N, Typ);
3782
3783          --  For all other cases, the attribute is handled by the back end, but
3784          --  we need to deal with the case of the range check on a universal
3785          --  integer.
3786
3787          else
3788             Apply_Universal_Integer_Attribute_Checks (N);
3789          end if;
3790       end Range_Length;
3791
3792       ----------
3793       -- Read --
3794       ----------
3795
3796       when Attribute_Read => Read : declare
3797          P_Type : constant Entity_Id := Entity (Pref);
3798          B_Type : constant Entity_Id := Base_Type (P_Type);
3799          U_Type : constant Entity_Id := Underlying_Type (P_Type);
3800          Pname  : Entity_Id;
3801          Decl   : Node_Id;
3802          Prag   : Node_Id;
3803          Arg2   : Node_Id;
3804          Rfunc  : Node_Id;
3805          Lhs    : Node_Id;
3806          Rhs    : Node_Id;
3807
3808       begin
3809          --  If no underlying type, we have an error that will be diagnosed
3810          --  elsewhere, so here we just completely ignore the expansion.
3811
3812          if No (U_Type) then
3813             return;
3814          end if;
3815
3816          --  The simple case, if there is a TSS for Read, just call it
3817
3818          Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
3819
3820          if Present (Pname) then
3821             null;
3822
3823          else
3824             --  If there is a Stream_Convert pragma, use it, we rewrite
3825
3826             --     sourcetyp'Read (stream, Item)
3827
3828             --  as
3829
3830             --     Item := sourcetyp (strmread (strmtyp'Input (Stream)));
3831
3832             --  where strmread is the given Read function that converts an
3833             --  argument of type strmtyp to type sourcetyp or a type from which
3834             --  it is derived. The conversion to sourcetyp is required in the
3835             --  latter case.
3836
3837             --  A special case arises if Item is a type conversion in which
3838             --  case, we have to expand to:
3839
3840             --     Itemx := typex (strmread (strmtyp'Input (Stream)));
3841
3842             --  where Itemx is the expression of the type conversion (i.e.
3843             --  the actual object), and typex is the type of Itemx.
3844
3845             Prag := Get_Stream_Convert_Pragma (P_Type);
3846
3847             if Present (Prag) then
3848                Arg2  := Next (First (Pragma_Argument_Associations (Prag)));
3849                Rfunc := Entity (Expression (Arg2));
3850                Lhs := Relocate_Node (Next (First (Exprs)));
3851                Rhs :=
3852                  OK_Convert_To (B_Type,
3853                    Make_Function_Call (Loc,
3854                      Name => New_Occurrence_Of (Rfunc, Loc),
3855                      Parameter_Associations => New_List (
3856                        Make_Attribute_Reference (Loc,
3857                          Prefix =>
3858                            New_Occurrence_Of
3859                              (Etype (First_Formal (Rfunc)), Loc),
3860                          Attribute_Name => Name_Input,
3861                          Expressions => New_List (
3862                            Relocate_Node (First (Exprs)))))));
3863
3864                if Nkind (Lhs) = N_Type_Conversion then
3865                   Lhs := Expression (Lhs);
3866                   Rhs := Convert_To (Etype (Lhs), Rhs);
3867                end if;
3868
3869                Rewrite (N,
3870                  Make_Assignment_Statement (Loc,
3871                    Name       => Lhs,
3872                    Expression => Rhs));
3873                Set_Assignment_OK (Lhs);
3874                Analyze (N);
3875                return;
3876
3877             --  For elementary types, we call the I_xxx routine using the first
3878             --  parameter and then assign the result into the second parameter.
3879             --  We set Assignment_OK to deal with the conversion case.
3880
3881             elsif Is_Elementary_Type (U_Type) then
3882                declare
3883                   Lhs : Node_Id;
3884                   Rhs : Node_Id;
3885
3886                begin
3887                   Lhs := Relocate_Node (Next (First (Exprs)));
3888                   Rhs := Build_Elementary_Input_Call (N);
3889
3890                   if Nkind (Lhs) = N_Type_Conversion then
3891                      Lhs := Expression (Lhs);
3892                      Rhs := Convert_To (Etype (Lhs), Rhs);
3893                   end if;
3894
3895                   Set_Assignment_OK (Lhs);
3896
3897                   Rewrite (N,
3898                     Make_Assignment_Statement (Loc,
3899                       Name       => Lhs,
3900                       Expression => Rhs));
3901
3902                   Analyze (N);
3903                   return;
3904                end;
3905
3906             --  Array type case
3907
3908             elsif Is_Array_Type (U_Type) then
3909                Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
3910                Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3911
3912             --  Tagged type case, use the primitive Read function. Note that
3913             --  this will dispatch in the class-wide case which is what we want
3914
3915             elsif Is_Tagged_Type (U_Type) then
3916                Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
3917
3918             --  All other record type cases, including protected records. The
3919             --  latter only arise for expander generated code for handling
3920             --  shared passive partition access.
3921
3922             else
3923                pragma Assert
3924                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
3925
3926                --  Ada 2005 (AI-216): Program_Error is raised when executing
3927                --  the default implementation of the Read attribute of an
3928                --  Unchecked_Union type.
3929
3930                if Is_Unchecked_Union (Base_Type (U_Type)) then
3931                   Insert_Action (N,
3932                     Make_Raise_Program_Error (Loc,
3933                       Reason => PE_Unchecked_Union_Restriction));
3934                end if;
3935
3936                if Has_Discriminants (U_Type)
3937                  and then Present
3938                    (Discriminant_Default_Value (First_Discriminant (U_Type)))
3939                then
3940                   Build_Mutable_Record_Read_Procedure
3941                     (Loc, Full_Base (U_Type), Decl, Pname);
3942                else
3943                   Build_Record_Read_Procedure
3944                     (Loc, Full_Base (U_Type), Decl, Pname);
3945                end if;
3946
3947                --  Suppress checks, uninitialized or otherwise invalid
3948                --  data does not cause constraint errors to be raised for
3949                --  a complete record read.
3950
3951                Insert_Action (N, Decl, All_Checks);
3952             end if;
3953          end if;
3954
3955          Rewrite_Stream_Proc_Call (Pname);
3956       end Read;
3957
3958       ---------
3959       -- Ref --
3960       ---------
3961
3962       --  Ref is identical to To_Address, see To_Address for processing
3963
3964       ---------------
3965       -- Remainder --
3966       ---------------
3967
3968       --  Transforms 'Remainder into a call to the floating-point attribute
3969       --  function Remainder in Fat_xxx (where xxx is the root type)
3970
3971       when Attribute_Remainder =>
3972          Expand_Fpt_Attribute_RR (N);
3973
3974       ------------
3975       -- Result --
3976       ------------
3977
3978       --  Transform 'Result into reference to _Result formal. At the point
3979       --  where a legal 'Result attribute is expanded, we know that we are in
3980       --  the context of a _Postcondition function with a _Result parameter.
3981
3982       when Attribute_Result =>
3983          Rewrite (N, Make_Identifier (Loc, Chars => Name_uResult));
3984          Analyze_And_Resolve (N, Typ);
3985
3986       -----------
3987       -- Round --
3988       -----------
3989
3990       --  The handling of the Round attribute is quite delicate. The processing
3991       --  in Sem_Attr introduced a conversion to universal real, reflecting the
3992       --  semantics of Round, but we do not want anything to do with universal
3993       --  real at runtime, since this corresponds to using floating-point
3994       --  arithmetic.
3995
3996       --  What we have now is that the Etype of the Round attribute correctly
3997       --  indicates the final result type. The operand of the Round is the
3998       --  conversion to universal real, described above, and the operand of
3999       --  this conversion is the actual operand of Round, which may be the
4000       --  special case of a fixed point multiplication or division (Etype =
4001       --  universal fixed)
4002
4003       --  The exapander will expand first the operand of the conversion, then
4004       --  the conversion, and finally the round attribute itself, since we
4005       --  always work inside out. But we cannot simply process naively in this
4006       --  order. In the semantic world where universal fixed and real really
4007       --  exist and have infinite precision, there is no problem, but in the
4008       --  implementation world, where universal real is a floating-point type,
4009       --  we would get the wrong result.
4010
4011       --  So the approach is as follows. First, when expanding a multiply or
4012       --  divide whose type is universal fixed, we do nothing at all, instead
4013       --  deferring the operation till later.
4014
4015       --  The actual processing is done in Expand_N_Type_Conversion which
4016       --  handles the special case of Round by looking at its parent to see if
4017       --  it is a Round attribute, and if it is, handling the conversion (or
4018       --  its fixed multiply/divide child) in an appropriate manner.
4019
4020       --  This means that by the time we get to expanding the Round attribute
4021       --  itself, the Round is nothing more than a type conversion (and will
4022       --  often be a null type conversion), so we just replace it with the
4023       --  appropriate conversion operation.
4024
4025       when Attribute_Round =>
4026          Rewrite (N,
4027            Convert_To (Etype (N), Relocate_Node (First (Exprs))));
4028          Analyze_And_Resolve (N);
4029
4030       --------------
4031       -- Rounding --
4032       --------------
4033
4034       --  Transforms 'Rounding into a call to the floating-point attribute
4035       --  function Rounding in Fat_xxx (where xxx is the root type)
4036
4037       when Attribute_Rounding =>
4038          Expand_Fpt_Attribute_R (N);
4039
4040       ------------------
4041       -- Same_Storage --
4042       ------------------
4043
4044       when Attribute_Same_Storage => Same_Storage : declare
4045          Loc : constant Source_Ptr := Sloc (N);
4046
4047          X   : constant Node_Id := Prefix (N);
4048          Y   : constant Node_Id := First (Expressions (N));
4049          --  The argumens
4050
4051          X_Addr, Y_Addr : Node_Id;
4052          --  the expressions for their addresses
4053
4054          X_Size, Y_Size : Node_Id;
4055          --  the expressions for their sizes
4056
4057       begin
4058          --  The attribute is expanded as:
4059
4060          --    (X'address = Y'address)
4061          --      and then (X'Size = Y'Size)
4062
4063          --  If both arguments have the same Etype the second conjunct can be
4064          --  omitted.
4065
4066          X_Addr :=
4067            Make_Attribute_Reference (Loc,
4068              Attribute_Name => Name_Address,
4069              Prefix         => New_Copy_Tree (X));
4070
4071          Y_Addr :=
4072            Make_Attribute_Reference (Loc,
4073              Attribute_Name => Name_Address,
4074              Prefix         => New_Copy_Tree (Y));
4075
4076          X_Size :=
4077            Make_Attribute_Reference (Loc,
4078              Attribute_Name => Name_Size,
4079              Prefix         => New_Copy_Tree (X));
4080
4081          Y_Size :=
4082            Make_Attribute_Reference (Loc,
4083              Attribute_Name => Name_Size,
4084              Prefix         => New_Copy_Tree (Y));
4085
4086          if Etype (X) = Etype (Y) then
4087             Rewrite (N,
4088               (Make_Op_Eq (Loc,
4089                  Left_Opnd  => X_Addr,
4090                  Right_Opnd => Y_Addr)));
4091          else
4092             Rewrite (N,
4093               Make_Op_And (Loc,
4094                 Left_Opnd  =>
4095                   Make_Op_Eq (Loc,
4096                     Left_Opnd  => X_Addr,
4097                     Right_Opnd => Y_Addr),
4098                 Right_Opnd =>
4099                   Make_Op_Eq (Loc,
4100                     Left_Opnd  => X_Size,
4101                     Right_Opnd => Y_Size)));
4102          end if;
4103
4104          Analyze_And_Resolve (N, Standard_Boolean);
4105       end Same_Storage;
4106
4107       -------------
4108       -- Scaling --
4109       -------------
4110
4111       --  Transforms 'Scaling into a call to the floating-point attribute
4112       --  function Scaling in Fat_xxx (where xxx is the root type)
4113
4114       when Attribute_Scaling =>
4115          Expand_Fpt_Attribute_RI (N);
4116
4117       ----------
4118       -- Size --
4119       ----------
4120
4121       when Attribute_Size        |
4122            Attribute_Object_Size |
4123            Attribute_Value_Size  |
4124            Attribute_VADS_Size   => Size :
4125
4126       declare
4127          Siz      : Uint;
4128          New_Node : Node_Id;
4129
4130       begin
4131          --  Processing for VADS_Size case. Note that this processing removes
4132          --  all traces of VADS_Size from the tree, and completes all required
4133          --  processing for VADS_Size by translating the attribute reference
4134          --  to an appropriate Size or Object_Size reference.
4135
4136          if Id = Attribute_VADS_Size
4137            or else (Use_VADS_Size and then Id = Attribute_Size)
4138          then
4139             --  If the size is specified, then we simply use the specified
4140             --  size. This applies to both types and objects. The size of an
4141             --  object can be specified in the following ways:
4142
4143             --    An explicit size object is given for an object
4144             --    A component size is specified for an indexed component
4145             --    A component clause is specified for a selected component
4146             --    The object is a component of a packed composite object
4147
4148             --  If the size is specified, then VADS_Size of an object
4149
4150             if (Is_Entity_Name (Pref)
4151                  and then Present (Size_Clause (Entity (Pref))))
4152               or else
4153                 (Nkind (Pref) = N_Component_Clause
4154                   and then (Present (Component_Clause
4155                                      (Entity (Selector_Name (Pref))))
4156                              or else Is_Packed (Etype (Prefix (Pref)))))
4157               or else
4158                 (Nkind (Pref) = N_Indexed_Component
4159                   and then (Component_Size (Etype (Prefix (Pref))) /= 0
4160                              or else Is_Packed (Etype (Prefix (Pref)))))
4161             then
4162                Set_Attribute_Name (N, Name_Size);
4163
4164             --  Otherwise if we have an object rather than a type, then the
4165             --  VADS_Size attribute applies to the type of the object, rather
4166             --  than the object itself. This is one of the respects in which
4167             --  VADS_Size differs from Size.
4168
4169             else
4170                if (not Is_Entity_Name (Pref)
4171                     or else not Is_Type (Entity (Pref)))
4172                  and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp))
4173                then
4174                   Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
4175                end if;
4176
4177                --  For a scalar type for which no size was explicitly given,
4178                --  VADS_Size means Object_Size. This is the other respect in
4179                --  which VADS_Size differs from Size.
4180
4181                if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then
4182                   Set_Attribute_Name (N, Name_Object_Size);
4183
4184                --  In all other cases, Size and VADS_Size are the sane
4185
4186                else
4187                   Set_Attribute_Name (N, Name_Size);
4188                end if;
4189             end if;
4190          end if;
4191
4192          --  For class-wide types, X'Class'Size is transformed into a direct
4193          --  reference to the Size of the class type, so that the back end does
4194          --  not have to deal with the X'Class'Size reference.
4195
4196          if Is_Entity_Name (Pref)
4197            and then Is_Class_Wide_Type (Entity (Pref))
4198          then
4199             Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
4200             return;
4201
4202          --  For X'Size applied to an object of a class-wide type, transform
4203          --  X'Size into a call to the primitive operation _Size applied to X.
4204
4205          elsif Is_Class_Wide_Type (Ptyp)
4206            or else (Id = Attribute_Size
4207                       and then Is_Tagged_Type (Ptyp)
4208                       and then Has_Unknown_Discriminants (Ptyp))
4209          then
4210             --  No need to do anything else compiling under restriction
4211             --  No_Dispatching_Calls. During the semantic analysis we
4212             --  already notified such violation.
4213
4214             if Restriction_Active (No_Dispatching_Calls) then
4215                return;
4216             end if;
4217
4218             New_Node :=
4219               Make_Function_Call (Loc,
4220                 Name => New_Reference_To
4221                   (Find_Prim_Op (Ptyp, Name_uSize), Loc),
4222                 Parameter_Associations => New_List (Pref));
4223
4224             if Typ /= Standard_Long_Long_Integer then
4225
4226                --  The context is a specific integer type with which the
4227                --  original attribute was compatible. The function has a
4228                --  specific type as well, so to preserve the compatibility
4229                --  we must convert explicitly.
4230
4231                New_Node := Convert_To (Typ, New_Node);
4232             end if;
4233
4234             Rewrite (N, New_Node);
4235             Analyze_And_Resolve (N, Typ);
4236             return;
4237
4238          --  Case of known RM_Size of a type
4239
4240          elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
4241            and then Is_Entity_Name (Pref)
4242            and then Is_Type (Entity (Pref))
4243            and then Known_Static_RM_Size (Entity (Pref))
4244          then
4245             Siz := RM_Size (Entity (Pref));
4246
4247          --  Case of known Esize of a type
4248
4249          elsif Id = Attribute_Object_Size
4250            and then Is_Entity_Name (Pref)
4251            and then Is_Type (Entity (Pref))
4252            and then Known_Static_Esize (Entity (Pref))
4253          then
4254             Siz := Esize (Entity (Pref));
4255
4256          --  Case of known size of object
4257
4258          elsif Id = Attribute_Size
4259            and then Is_Entity_Name (Pref)
4260            and then Is_Object (Entity (Pref))
4261            and then Known_Esize (Entity (Pref))
4262            and then Known_Static_Esize (Entity (Pref))
4263          then
4264             Siz := Esize (Entity (Pref));
4265
4266          --  For an array component, we can do Size in the front end
4267          --  if the component_size of the array is set.
4268
4269          elsif Nkind (Pref) = N_Indexed_Component then
4270             Siz := Component_Size (Etype (Prefix (Pref)));
4271
4272          --  For a record component, we can do Size in the front end if there
4273          --  is a component clause, or if the record is packed and the
4274          --  component's size is known at compile time.
4275
4276          elsif Nkind (Pref) = N_Selected_Component then
4277             declare
4278                Rec  : constant Entity_Id := Etype (Prefix (Pref));
4279                Comp : constant Entity_Id := Entity (Selector_Name (Pref));
4280
4281             begin
4282                if Present (Component_Clause (Comp)) then
4283                   Siz := Esize (Comp);
4284
4285                elsif Is_Packed (Rec) then
4286                   Siz := RM_Size (Ptyp);
4287
4288                else
4289                   Apply_Universal_Integer_Attribute_Checks (N);
4290                   return;
4291                end if;
4292             end;
4293
4294          --  All other cases are handled by the back end
4295
4296          else
4297             Apply_Universal_Integer_Attribute_Checks (N);
4298
4299             --  If Size is applied to a formal parameter that is of a packed
4300             --  array subtype, then apply Size to the actual subtype.
4301
4302             if Is_Entity_Name (Pref)
4303               and then Is_Formal (Entity (Pref))
4304               and then Is_Array_Type (Ptyp)
4305               and then Is_Packed (Ptyp)
4306             then
4307                Rewrite (N,
4308                  Make_Attribute_Reference (Loc,
4309                    Prefix =>
4310                      New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
4311                    Attribute_Name => Name_Size));
4312                Analyze_And_Resolve (N, Typ);
4313             end if;
4314
4315             --  If Size applies to a dereference of an access to unconstrained
4316             --  packed array, the back end needs to see its unconstrained
4317             --  nominal type, but also a hint to the actual constrained type.
4318
4319             if Nkind (Pref) = N_Explicit_Dereference
4320               and then Is_Array_Type (Ptyp)
4321               and then not Is_Constrained (Ptyp)
4322               and then Is_Packed (Ptyp)
4323             then
4324                Set_Actual_Designated_Subtype (Pref,
4325                  Get_Actual_Subtype (Pref));
4326             end if;
4327
4328             return;
4329          end if;
4330
4331          --  Common processing for record and array component case
4332
4333          if Siz /= No_Uint and then Siz /= 0 then
4334             declare
4335                CS : constant Boolean := Comes_From_Source (N);
4336
4337             begin
4338                Rewrite (N, Make_Integer_Literal (Loc, Siz));
4339
4340                --  This integer literal is not a static expression. We do not
4341                --  call Analyze_And_Resolve here, because this would activate
4342                --  the circuit for deciding that a static value was out of
4343                --  range, and we don't want that.
4344
4345                --  So just manually set the type, mark the expression as non-
4346                --  static, and then ensure that the result is checked properly
4347                --  if the attribute comes from source (if it was internally
4348                --  generated, we never need a constraint check).
4349
4350                Set_Etype (N, Typ);
4351                Set_Is_Static_Expression (N, False);
4352
4353                if CS then
4354                   Apply_Constraint_Check (N, Typ);
4355                end if;
4356             end;
4357          end if;
4358       end Size;
4359
4360       ------------------
4361       -- Storage_Pool --
4362       ------------------
4363
4364       when Attribute_Storage_Pool =>
4365          Rewrite (N,
4366            Make_Type_Conversion (Loc,
4367              Subtype_Mark => New_Reference_To (Etype (N), Loc),
4368              Expression   => New_Reference_To (Entity (N), Loc)));
4369          Analyze_And_Resolve (N, Typ);
4370
4371       ------------------
4372       -- Storage_Size --
4373       ------------------
4374
4375       when Attribute_Storage_Size => Storage_Size : begin
4376
4377          --  Access type case, always go to the root type
4378
4379          --  The case of access types results in a value of zero for the case
4380          --  where no storage size attribute clause has been given. If a
4381          --  storage size has been given, then the attribute is converted
4382          --  to a reference to the variable used to hold this value.
4383
4384          if Is_Access_Type (Ptyp) then
4385             if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
4386                Rewrite (N,
4387                  Make_Attribute_Reference (Loc,
4388                    Prefix => New_Reference_To (Typ, Loc),
4389                    Attribute_Name => Name_Max,
4390                    Expressions => New_List (
4391                      Make_Integer_Literal (Loc, 0),
4392                      Convert_To (Typ,
4393                        New_Reference_To
4394                          (Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
4395
4396             elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
4397                Rewrite (N,
4398                  OK_Convert_To (Typ,
4399                    Make_Function_Call (Loc,
4400                      Name =>
4401                        New_Reference_To
4402                          (Find_Prim_Op
4403                            (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
4404                             Attribute_Name (N)),
4405                           Loc),
4406
4407                      Parameter_Associations => New_List (
4408                        New_Reference_To
4409                          (Associated_Storage_Pool (Root_Type (Ptyp)), Loc)))));
4410
4411             else
4412                Rewrite (N, Make_Integer_Literal (Loc, 0));
4413             end if;
4414
4415             Analyze_And_Resolve (N, Typ);
4416
4417          --  For tasks, we retrieve the size directly from the TCB. The
4418          --  size may depend on a discriminant of the type, and therefore
4419          --  can be a per-object expression, so type-level information is
4420          --  not sufficient in general. There are four cases to consider:
4421
4422          --  a) If the attribute appears within a task body, the designated
4423          --    TCB is obtained by a call to Self.
4424
4425          --  b) If the prefix of the attribute is the name of a task object,
4426          --  the designated TCB is the one stored in the corresponding record.
4427
4428          --  c) If the prefix is a task type, the size is obtained from the
4429          --  size variable created for each task type
4430
4431          --  d) If no storage_size was specified for the type , there is no
4432          --  size variable, and the value is a system-specific default.
4433
4434          else
4435             if In_Open_Scopes (Ptyp) then
4436
4437                --  Storage_Size (Self)
4438
4439                Rewrite (N,
4440                  Convert_To (Typ,
4441                    Make_Function_Call (Loc,
4442                      Name =>
4443                        New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
4444                      Parameter_Associations =>
4445                        New_List (
4446                          Make_Function_Call (Loc,
4447                            Name =>
4448                              New_Reference_To (RTE (RE_Self), Loc))))));
4449
4450             elsif not Is_Entity_Name (Pref)
4451               or else not Is_Type (Entity (Pref))
4452             then
4453                --  Storage_Size (Rec (Obj).Size)
4454
4455                Rewrite (N,
4456                  Convert_To (Typ,
4457                    Make_Function_Call (Loc,
4458                      Name =>
4459                        New_Occurrence_Of (RTE (RE_Storage_Size), Loc),
4460                        Parameter_Associations =>
4461                           New_List (
4462                             Make_Selected_Component (Loc,
4463                               Prefix =>
4464                                 Unchecked_Convert_To (
4465                                   Corresponding_Record_Type (Ptyp),
4466                                     New_Copy_Tree (Pref)),
4467                               Selector_Name =>
4468                                  Make_Identifier (Loc, Name_uTask_Id))))));
4469
4470             elsif Present (Storage_Size_Variable (Ptyp)) then
4471
4472                --  Static storage size pragma given for type: retrieve value
4473                --  from its allocated storage variable.
4474
4475                Rewrite (N,
4476                  Convert_To (Typ,
4477                    Make_Function_Call (Loc,
4478                      Name => New_Occurrence_Of (
4479                        RTE (RE_Adjust_Storage_Size), Loc),
4480                      Parameter_Associations =>
4481                        New_List (
4482                          New_Reference_To (
4483                            Storage_Size_Variable (Ptyp), Loc)))));
4484             else
4485                --  Get system default
4486
4487                Rewrite (N,
4488                  Convert_To (Typ,
4489                    Make_Function_Call (Loc,
4490                      Name =>
4491                        New_Occurrence_Of (
4492                         RTE (RE_Default_Stack_Size), Loc))));
4493             end if;
4494
4495             Analyze_And_Resolve (N, Typ);
4496          end if;
4497       end Storage_Size;
4498
4499       -----------------
4500       -- Stream_Size --
4501       -----------------
4502
4503       when Attribute_Stream_Size =>
4504          Rewrite (N,
4505            Make_Integer_Literal (Loc, Intval => Get_Stream_Size (Ptyp)));
4506          Analyze_And_Resolve (N, Typ);
4507
4508       ----------
4509       -- Succ --
4510       ----------
4511
4512       --  1. Deal with enumeration types with holes
4513       --  2. For floating-point, generate call to attribute function
4514       --  3. For other cases, deal with constraint checking
4515
4516       when Attribute_Succ => Succ : declare
4517          Etyp : constant Entity_Id := Base_Type (Ptyp);
4518
4519       begin
4520
4521          --  For enumeration types with non-standard representations, we
4522          --  expand typ'Succ (x) into
4523
4524          --    Pos_To_Rep (Rep_To_Pos (x) + 1)
4525
4526          --    If the representation is contiguous, we compute instead
4527          --    Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
4528
4529          if Is_Enumeration_Type (Ptyp)
4530            and then Present (Enum_Pos_To_Rep (Etyp))
4531          then
4532             if Has_Contiguous_Rep (Etyp) then
4533                Rewrite (N,
4534                   Unchecked_Convert_To (Ptyp,
4535                      Make_Op_Add (Loc,
4536                         Left_Opnd  =>
4537                          Make_Integer_Literal (Loc,
4538                            Enumeration_Rep (First_Literal (Ptyp))),
4539                         Right_Opnd =>
4540                           Make_Function_Call (Loc,
4541                             Name =>
4542                               New_Reference_To
4543                                (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4544
4545                             Parameter_Associations =>
4546                               New_List (
4547                                 Unchecked_Convert_To (Ptyp,
4548                                   Make_Op_Add (Loc,
4549                                   Left_Opnd =>
4550                                     Unchecked_Convert_To (Standard_Integer,
4551                                       Relocate_Node (First (Exprs))),
4552                                   Right_Opnd =>
4553                                     Make_Integer_Literal (Loc, 1))),
4554                                 Rep_To_Pos_Flag (Ptyp, Loc))))));
4555             else
4556                --  Add Boolean parameter True, to request program errror if
4557                --  we have a bad representation on our hands. Add False if
4558                --  checks are suppressed.
4559
4560                Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
4561                Rewrite (N,
4562                  Make_Indexed_Component (Loc,
4563                    Prefix =>
4564                      New_Reference_To
4565                        (Enum_Pos_To_Rep (Etyp), Loc),
4566                    Expressions => New_List (
4567                      Make_Op_Add (Loc,
4568                        Left_Opnd =>
4569                          Make_Function_Call (Loc,
4570                            Name =>
4571                              New_Reference_To
4572                                (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4573                            Parameter_Associations => Exprs),
4574                        Right_Opnd => Make_Integer_Literal (Loc, 1)))));
4575             end if;
4576
4577             Analyze_And_Resolve (N, Typ);
4578
4579          --  For floating-point, we transform 'Succ into a call to the Succ
4580          --  floating-point attribute function in Fat_xxx (xxx is root type)
4581
4582          elsif Is_Floating_Point_Type (Ptyp) then
4583             Expand_Fpt_Attribute_R (N);
4584             Analyze_And_Resolve (N, Typ);
4585
4586          --  For modular types, nothing to do (no overflow, since wraps)
4587
4588          elsif Is_Modular_Integer_Type (Ptyp) then
4589             null;
4590
4591          --  For other types, if argument is marked as needing a range check or
4592          --  overflow checking is enabled, we must generate a check.
4593
4594          elsif not Overflow_Checks_Suppressed (Ptyp)
4595            or else Do_Range_Check (First (Exprs))
4596          then
4597             Set_Do_Range_Check (First (Exprs), False);
4598             Expand_Pred_Succ (N);
4599          end if;
4600       end Succ;
4601
4602       ---------
4603       -- Tag --
4604       ---------
4605
4606       --  Transforms X'Tag into a direct reference to the tag of X
4607
4608       when Attribute_Tag => Tag : declare
4609          Ttyp           : Entity_Id;
4610          Prefix_Is_Type : Boolean;
4611
4612       begin
4613          if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then
4614             Ttyp := Entity (Pref);
4615             Prefix_Is_Type := True;
4616          else
4617             Ttyp := Ptyp;
4618             Prefix_Is_Type := False;
4619          end if;
4620
4621          if Is_Class_Wide_Type (Ttyp) then
4622             Ttyp := Root_Type (Ttyp);
4623          end if;
4624
4625          Ttyp := Underlying_Type (Ttyp);
4626
4627          --  Ada 2005: The type may be a synchronized tagged type, in which
4628          --  case the tag information is stored in the corresponding record.
4629
4630          if Is_Concurrent_Type (Ttyp) then
4631             Ttyp := Corresponding_Record_Type (Ttyp);
4632          end if;
4633
4634          if Prefix_Is_Type then
4635
4636             --  For VMs we leave the type attribute unexpanded because
4637             --  there's not a dispatching table to reference.
4638
4639             if Tagged_Type_Expansion then
4640                Rewrite (N,
4641                  Unchecked_Convert_To (RTE (RE_Tag),
4642                    New_Reference_To
4643                      (Node (First_Elmt (Access_Disp_Table (Ttyp))), Loc)));
4644                Analyze_And_Resolve (N, RTE (RE_Tag));
4645             end if;
4646
4647          --  Ada 2005 (AI-251): The use of 'Tag in the sources always
4648          --  references the primary tag of the actual object. If 'Tag is
4649          --  applied to class-wide interface objects we generate code that
4650          --  displaces "this" to reference the base of the object.
4651
4652          elsif Comes_From_Source (N)
4653             and then Is_Class_Wide_Type (Etype (Prefix (N)))
4654             and then Is_Interface (Etype (Prefix (N)))
4655          then
4656             --  Generate:
4657             --    (To_Tag_Ptr (Prefix'Address)).all
4658
4659             --  Note that Prefix'Address is recursively expanded into a call
4660             --  to Base_Address (Obj.Tag)
4661
4662             --  Not needed for VM targets, since all handled by the VM
4663
4664             if Tagged_Type_Expansion then
4665                Rewrite (N,
4666                  Make_Explicit_Dereference (Loc,
4667                    Unchecked_Convert_To (RTE (RE_Tag_Ptr),
4668                      Make_Attribute_Reference (Loc,
4669                        Prefix => Relocate_Node (Pref),
4670                        Attribute_Name => Name_Address))));
4671                Analyze_And_Resolve (N, RTE (RE_Tag));
4672             end if;
4673
4674          else
4675             Rewrite (N,
4676               Make_Selected_Component (Loc,
4677                 Prefix => Relocate_Node (Pref),
4678                 Selector_Name =>
4679                   New_Reference_To (First_Tag_Component (Ttyp), Loc)));
4680             Analyze_And_Resolve (N, RTE (RE_Tag));
4681          end if;
4682       end Tag;
4683
4684       ----------------
4685       -- Terminated --
4686       ----------------
4687
4688       --  Transforms 'Terminated attribute into a call to Terminated function
4689
4690       when Attribute_Terminated => Terminated :
4691       begin
4692          --  The prefix of Terminated is of a task interface class-wide type.
4693          --  Generate:
4694          --    terminated (Task_Id (Pref._disp_get_task_id));
4695
4696          if Ada_Version >= Ada_2005
4697            and then Ekind (Ptyp) = E_Class_Wide_Type
4698            and then Is_Interface (Ptyp)
4699            and then Is_Task_Interface (Ptyp)
4700          then
4701             Rewrite (N,
4702               Make_Function_Call (Loc,
4703                 Name =>
4704                   New_Reference_To (RTE (RE_Terminated), Loc),
4705                 Parameter_Associations => New_List (
4706                   Make_Unchecked_Type_Conversion (Loc,
4707                     Subtype_Mark =>
4708                       New_Reference_To (RTE (RO_ST_Task_Id), Loc),
4709                     Expression =>
4710                       Make_Selected_Component (Loc,
4711                         Prefix =>
4712                           New_Copy_Tree (Pref),
4713                         Selector_Name =>
4714                           Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
4715
4716          elsif Restricted_Profile then
4717             Rewrite (N,
4718               Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
4719
4720          else
4721             Rewrite (N,
4722               Build_Call_With_Task (Pref, RTE (RE_Terminated)));
4723          end if;
4724
4725          Analyze_And_Resolve (N, Standard_Boolean);
4726       end Terminated;
4727
4728       ----------------
4729       -- To_Address --
4730       ----------------
4731
4732       --  Transforms System'To_Address (X) and System.Address'Ref (X) into
4733       --  unchecked conversion from (integral) type of X to type address.
4734
4735       when Attribute_To_Address | Attribute_Ref =>
4736          Rewrite (N,
4737            Unchecked_Convert_To (RTE (RE_Address),
4738              Relocate_Node (First (Exprs))));
4739          Analyze_And_Resolve (N, RTE (RE_Address));
4740
4741       ------------
4742       -- To_Any --
4743       ------------
4744
4745       when Attribute_To_Any => To_Any : declare
4746          P_Type : constant Entity_Id := Etype (Pref);
4747          Decls  : constant List_Id   := New_List;
4748       begin
4749          Rewrite (N,
4750            Build_To_Any_Call
4751              (Convert_To (P_Type,
4752               Relocate_Node (First (Exprs))), Decls));
4753          Insert_Actions (N, Decls);
4754          Analyze_And_Resolve (N, RTE (RE_Any));
4755       end To_Any;
4756
4757       ----------------
4758       -- Truncation --
4759       ----------------
4760
4761       --  Transforms 'Truncation into a call to the floating-point attribute
4762       --  function Truncation in Fat_xxx (where xxx is the root type).
4763       --  Expansion is avoided for cases the back end can handle directly.
4764
4765       when Attribute_Truncation =>
4766          if not Is_Inline_Floating_Point_Attribute (N) then
4767             Expand_Fpt_Attribute_R (N);
4768          end if;
4769
4770       --------------
4771       -- TypeCode --
4772       --------------
4773
4774       when Attribute_TypeCode => TypeCode : declare
4775          P_Type : constant Entity_Id := Etype (Pref);
4776          Decls  : constant List_Id   := New_List;
4777       begin
4778          Rewrite (N, Build_TypeCode_Call (Loc, P_Type, Decls));
4779          Insert_Actions (N, Decls);
4780          Analyze_And_Resolve (N, RTE (RE_TypeCode));
4781       end TypeCode;
4782
4783       -----------------------
4784       -- Unbiased_Rounding --
4785       -----------------------
4786
4787       --  Transforms 'Unbiased_Rounding into a call to the floating-point
4788       --  attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
4789       --  root type). Expansion is avoided for cases the back end can handle
4790       --  directly.
4791
4792       when Attribute_Unbiased_Rounding =>
4793          if not Is_Inline_Floating_Point_Attribute (N) then
4794             Expand_Fpt_Attribute_R (N);
4795          end if;
4796
4797       -----------------
4798       -- UET_Address --
4799       -----------------
4800
4801       when Attribute_UET_Address => UET_Address : declare
4802          Ent : constant Entity_Id := Make_Temporary (Loc, 'T');
4803
4804       begin
4805          Insert_Action (N,
4806            Make_Object_Declaration (Loc,
4807              Defining_Identifier => Ent,
4808              Aliased_Present     => True,
4809              Object_Definition   =>
4810                New_Occurrence_Of (RTE (RE_Address), Loc)));
4811
4812          --  Construct name __gnat_xxx__SDP, where xxx is the unit name
4813          --  in normal external form.
4814
4815          Get_External_Unit_Name_String (Get_Unit_Name (Pref));
4816          Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
4817          Name_Len := Name_Len + 7;
4818          Name_Buffer (1 .. 7) := "__gnat_";
4819          Name_Buffer (Name_Len + 1 .. Name_Len + 5) := "__SDP";
4820          Name_Len := Name_Len + 5;
4821
4822          Set_Is_Imported (Ent);
4823          Set_Interface_Name (Ent,
4824            Make_String_Literal (Loc,
4825              Strval => String_From_Name_Buffer));
4826
4827          --  Set entity as internal to ensure proper Sprint output of its
4828          --  implicit importation.
4829
4830          Set_Is_Internal (Ent);
4831
4832          Rewrite (N,
4833            Make_Attribute_Reference (Loc,
4834              Prefix => New_Occurrence_Of (Ent, Loc),
4835              Attribute_Name => Name_Address));
4836
4837          Analyze_And_Resolve (N, Typ);
4838       end UET_Address;
4839
4840       ---------------
4841       -- VADS_Size --
4842       ---------------
4843
4844       --  The processing for VADS_Size is shared with Size
4845
4846       ---------
4847       -- Val --
4848       ---------
4849
4850       --  For enumeration types with a standard representation, and for all
4851       --  other types, Val is handled by the back end. For enumeration types
4852       --  with a non-standard representation we use the _Pos_To_Rep array that
4853       --  was created when the type was frozen.
4854
4855       when Attribute_Val => Val : declare
4856          Etyp : constant Entity_Id := Base_Type (Entity (Pref));
4857
4858       begin
4859          if Is_Enumeration_Type (Etyp)
4860            and then Present (Enum_Pos_To_Rep (Etyp))
4861          then
4862             if Has_Contiguous_Rep (Etyp) then
4863                declare
4864                   Rep_Node : constant Node_Id :=
4865                     Unchecked_Convert_To (Etyp,
4866                        Make_Op_Add (Loc,
4867                          Left_Opnd =>
4868                             Make_Integer_Literal (Loc,
4869                               Enumeration_Rep (First_Literal (Etyp))),
4870                          Right_Opnd =>
4871                           (Convert_To (Standard_Integer,
4872                              Relocate_Node (First (Exprs))))));
4873
4874                begin
4875                   Rewrite (N,
4876                      Unchecked_Convert_To (Etyp,
4877                          Make_Op_Add (Loc,
4878                            Left_Opnd =>
4879                              Make_Integer_Literal (Loc,
4880                                Enumeration_Rep (First_Literal (Etyp))),
4881                            Right_Opnd =>
4882                              Make_Function_Call (Loc,
4883                                Name =>
4884                                  New_Reference_To
4885                                    (TSS (Etyp, TSS_Rep_To_Pos), Loc),
4886                                Parameter_Associations => New_List (
4887                                  Rep_Node,
4888                                  Rep_To_Pos_Flag (Etyp, Loc))))));
4889                end;
4890
4891             else
4892                Rewrite (N,
4893                  Make_Indexed_Component (Loc,
4894                    Prefix => New_Reference_To (Enum_Pos_To_Rep (Etyp), Loc),
4895                    Expressions => New_List (
4896                      Convert_To (Standard_Integer,
4897                        Relocate_Node (First (Exprs))))));
4898             end if;
4899
4900             Analyze_And_Resolve (N, Typ);
4901
4902          --  If the argument is marked as requiring a range check then generate
4903          --  it here.
4904
4905          elsif Do_Range_Check (First (Exprs)) then
4906             Set_Do_Range_Check (First (Exprs), False);
4907             Generate_Range_Check (First (Exprs), Etyp, CE_Range_Check_Failed);
4908          end if;
4909       end Val;
4910
4911       -----------
4912       -- Valid --
4913       -----------
4914
4915       --  The code for valid is dependent on the particular types involved.
4916       --  See separate sections below for the generated code in each case.
4917
4918       when Attribute_Valid => Valid : declare
4919          Btyp : Entity_Id := Base_Type (Ptyp);
4920          Tst  : Node_Id;
4921
4922          Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
4923          --  Save the validity checking mode. We always turn off validity
4924          --  checking during process of 'Valid since this is one place
4925          --  where we do not want the implicit validity checks to intefere
4926          --  with the explicit validity check that the programmer is doing.
4927
4928          function Make_Range_Test return Node_Id;
4929          --  Build the code for a range test of the form
4930          --    Btyp!(Pref) in Btyp!(Ptyp'First) .. Btyp!(Ptyp'Last)
4931
4932          ---------------------
4933          -- Make_Range_Test --
4934          ---------------------
4935
4936          function Make_Range_Test return Node_Id is
4937             Temp : constant Node_Id := Duplicate_Subexpr (Pref);
4938
4939          begin
4940             --  The value whose validity is being checked has been captured in
4941             --  an object declaration. We certainly don't want this object to
4942             --  appear valid because the declaration initializes it!
4943
4944             if Is_Entity_Name (Temp) then
4945                Set_Is_Known_Valid (Entity (Temp), False);
4946             end if;
4947
4948             return
4949               Make_In (Loc,
4950                 Left_Opnd  =>
4951                   Unchecked_Convert_To (Btyp, Temp),
4952                 Right_Opnd =>
4953                   Make_Range (Loc,
4954                     Low_Bound =>
4955                       Unchecked_Convert_To (Btyp,
4956                         Make_Attribute_Reference (Loc,
4957                           Prefix => New_Occurrence_Of (Ptyp, Loc),
4958                           Attribute_Name => Name_First)),
4959                     High_Bound =>
4960                       Unchecked_Convert_To (Btyp,
4961                         Make_Attribute_Reference (Loc,
4962                           Prefix => New_Occurrence_Of (Ptyp, Loc),
4963                           Attribute_Name => Name_Last))));
4964          end Make_Range_Test;
4965
4966       --  Start of processing for Attribute_Valid
4967
4968       begin
4969          --  Do not expand sourced code 'Valid reference in CodePeer mode,
4970          --  will be handled by the back-end directly.
4971
4972          if CodePeer_Mode and then Comes_From_Source (N) then
4973             return;
4974          end if;
4975
4976          --  Turn off validity checks. We do not want any implicit validity
4977          --  checks to intefere with the explicit check from the attribute
4978
4979          Validity_Checks_On := False;
4980
4981          --  Floating-point case. This case is handled by the Valid attribute
4982          --  code in the floating-point attribute run-time library.
4983
4984          if Is_Floating_Point_Type (Ptyp) then
4985             declare
4986                Pkg : RE_Id;
4987                Ftp : Entity_Id;
4988
4989             begin
4990
4991                case Float_Rep (Btyp) is
4992
4993                   --  For vax fpt types, call appropriate routine in special
4994                   --  vax floating point unit. No need to worry about loads in
4995                   --  this case, since these types have no signalling NaN's.
4996
4997                   when VAX_Native => Expand_Vax_Valid (N);
4998
4999                   --  The AAMP back end handles Valid for floating-point types
5000
5001                   when AAMP =>
5002                      Analyze_And_Resolve (Pref, Ptyp);
5003                      Set_Etype (N, Standard_Boolean);
5004                      Set_Analyzed (N);
5005
5006                   when IEEE_Binary =>
5007                      Find_Fat_Info (Ptyp, Ftp, Pkg);
5008
5009                      --  If the floating-point object might be unaligned, we
5010                      --  need to call the special routine Unaligned_Valid,
5011                      --  which makes the needed copy, being careful not to
5012                      --  load the value into any floating-point register.
5013                      --  The argument in this case is obj'Address (see
5014                      --  Unaligned_Valid routine in Fat_Gen).
5015
5016                      if Is_Possibly_Unaligned_Object (Pref) then
5017                         Expand_Fpt_Attribute
5018                           (N, Pkg, Name_Unaligned_Valid,
5019                            New_List (
5020                              Make_Attribute_Reference (Loc,
5021                                Prefix => Relocate_Node (Pref),
5022                                Attribute_Name => Name_Address)));
5023
5024                      --  In the normal case where we are sure the object is
5025                      --  aligned, we generate a call to Valid, and the argument
5026                      --  in this case is obj'Unrestricted_Access (after
5027                      --  converting obj to the right floating-point type).
5028
5029                      else
5030                         Expand_Fpt_Attribute
5031                           (N, Pkg, Name_Valid,
5032                            New_List (
5033                              Make_Attribute_Reference (Loc,
5034                                Prefix => Unchecked_Convert_To (Ftp, Pref),
5035                                Attribute_Name => Name_Unrestricted_Access)));
5036                      end if;
5037                end case;
5038
5039                --  One more task, we still need a range check. Required
5040                --  only if we have a constraint, since the Valid routine
5041                --  catches infinities properly (infinities are never valid).
5042
5043                --  The way we do the range check is simply to create the
5044                --  expression: Valid (N) and then Base_Type(Pref) in Typ.
5045
5046                if not Subtypes_Statically_Match (Ptyp, Btyp) then
5047                   Rewrite (N,
5048                     Make_And_Then (Loc,
5049                       Left_Opnd  => Relocate_Node (N),
5050                       Right_Opnd =>
5051                         Make_In (Loc,
5052                           Left_Opnd => Convert_To (Btyp, Pref),
5053                           Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
5054                end if;
5055             end;
5056
5057          --  Enumeration type with holes
5058
5059          --  For enumeration types with holes, the Pos value constructed by
5060          --  the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
5061          --  second argument of False returns minus one for an invalid value,
5062          --  and the non-negative pos value for a valid value, so the
5063          --  expansion of X'Valid is simply:
5064
5065          --     type(X)'Pos (X) >= 0
5066
5067          --  We can't quite generate it that way because of the requirement
5068          --  for the non-standard second argument of False in the resulting
5069          --  rep_to_pos call, so we have to explicitly create:
5070
5071          --     _rep_to_pos (X, False) >= 0
5072
5073          --  If we have an enumeration subtype, we also check that the
5074          --  value is in range:
5075
5076          --    _rep_to_pos (X, False) >= 0
5077          --      and then
5078          --       (X >= type(X)'First and then type(X)'Last <= X)
5079
5080          elsif Is_Enumeration_Type (Ptyp)
5081            and then Present (Enum_Pos_To_Rep (Base_Type (Ptyp)))
5082          then
5083             Tst :=
5084               Make_Op_Ge (Loc,
5085                 Left_Opnd =>
5086                   Make_Function_Call (Loc,
5087                     Name =>
5088                       New_Reference_To
5089                         (TSS (Base_Type (Ptyp), TSS_Rep_To_Pos), Loc),
5090                     Parameter_Associations => New_List (
5091                       Pref,
5092                       New_Occurrence_Of (Standard_False, Loc))),
5093                 Right_Opnd => Make_Integer_Literal (Loc, 0));
5094
5095             if Ptyp /= Btyp
5096               and then
5097                 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
5098                   or else
5099                  Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
5100             then
5101                --  The call to Make_Range_Test will create declarations
5102                --  that need a proper insertion point, but Pref is now
5103                --  attached to a node with no ancestor. Attach to tree
5104                --  even if it is to be rewritten below.
5105
5106                Set_Parent (Tst, Parent (N));
5107
5108                Tst :=
5109                  Make_And_Then (Loc,
5110                    Left_Opnd  => Make_Range_Test,
5111                    Right_Opnd => Tst);
5112             end if;
5113
5114             Rewrite (N, Tst);
5115
5116          --  Fortran convention booleans
5117
5118          --  For the very special case of Fortran convention booleans, the
5119          --  value is always valid, since it is an integer with the semantics
5120          --  that non-zero is true, and any value is permissible.
5121
5122          elsif Is_Boolean_Type (Ptyp)
5123            and then Convention (Ptyp) = Convention_Fortran
5124          then
5125             Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
5126
5127          --  For biased representations, we will be doing an unchecked
5128          --  conversion without unbiasing the result. That means that the range
5129          --  test has to take this into account, and the proper form of the
5130          --  test is:
5131
5132          --    Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
5133
5134          elsif Has_Biased_Representation (Ptyp) then
5135             Btyp := RTE (RE_Unsigned_32);
5136             Rewrite (N,
5137               Make_Op_Lt (Loc,
5138                 Left_Opnd =>
5139                   Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
5140                 Right_Opnd =>
5141                   Unchecked_Convert_To (Btyp,
5142                     Make_Attribute_Reference (Loc,
5143                       Prefix => New_Occurrence_Of (Ptyp, Loc),
5144                       Attribute_Name => Name_Range_Length))));
5145
5146          --  For all other scalar types, what we want logically is a
5147          --  range test:
5148
5149          --     X in type(X)'First .. type(X)'Last
5150
5151          --  But that's precisely what won't work because of possible
5152          --  unwanted optimization (and indeed the basic motivation for
5153          --  the Valid attribute is exactly that this test does not work!)
5154          --  What will work is:
5155
5156          --     Btyp!(X) >= Btyp!(type(X)'First)
5157          --       and then
5158          --     Btyp!(X) <= Btyp!(type(X)'Last)
5159
5160          --  where Btyp is an integer type large enough to cover the full
5161          --  range of possible stored values (i.e. it is chosen on the basis
5162          --  of the size of the type, not the range of the values). We write
5163          --  this as two tests, rather than a range check, so that static
5164          --  evaluation will easily remove either or both of the checks if
5165          --  they can be -statically determined to be true (this happens
5166          --  when the type of X is static and the range extends to the full
5167          --  range of stored values).
5168
5169          --  Unsigned types. Note: it is safe to consider only whether the
5170          --  subtype is unsigned, since we will in that case be doing all
5171          --  unsigned comparisons based on the subtype range. Since we use the
5172          --  actual subtype object size, this is appropriate.
5173
5174          --  For example, if we have
5175
5176          --    subtype x is integer range 1 .. 200;
5177          --    for x'Object_Size use 8;
5178
5179          --  Now the base type is signed, but objects of this type are bits
5180          --  unsigned, and doing an unsigned test of the range 1 to 200 is
5181          --  correct, even though a value greater than 127 looks signed to a
5182          --  signed comparison.
5183
5184          elsif Is_Unsigned_Type (Ptyp) then
5185             if Esize (Ptyp) <= 32 then
5186                Btyp := RTE (RE_Unsigned_32);
5187             else
5188                Btyp := RTE (RE_Unsigned_64);
5189             end if;
5190
5191             Rewrite (N, Make_Range_Test);
5192
5193          --  Signed types
5194
5195          else
5196             if Esize (Ptyp) <= Esize (Standard_Integer) then
5197                Btyp := Standard_Integer;
5198             else
5199                Btyp := Universal_Integer;
5200             end if;
5201
5202             Rewrite (N, Make_Range_Test);
5203          end if;
5204
5205          Analyze_And_Resolve (N, Standard_Boolean);
5206          Validity_Checks_On := Save_Validity_Checks_On;
5207       end Valid;
5208
5209       -----------
5210       -- Value --
5211       -----------
5212
5213       --  Value attribute is handled in separate unit Exp_Imgv
5214
5215       when Attribute_Value =>
5216          Exp_Imgv.Expand_Value_Attribute (N);
5217
5218       -----------------
5219       -- Value_Size --
5220       -----------------
5221
5222       --  The processing for Value_Size shares the processing for Size
5223
5224       -------------
5225       -- Version --
5226       -------------
5227
5228       --  The processing for Version shares the processing for Body_Version
5229
5230       ----------------
5231       -- Wide_Image --
5232       ----------------
5233
5234       --  Wide_Image attribute is handled in separate unit Exp_Imgv
5235
5236       when Attribute_Wide_Image =>
5237          Exp_Imgv.Expand_Wide_Image_Attribute (N);
5238
5239       ---------------------
5240       -- Wide_Wide_Image --
5241       ---------------------
5242
5243       --  Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
5244
5245       when Attribute_Wide_Wide_Image =>
5246          Exp_Imgv.Expand_Wide_Wide_Image_Attribute (N);
5247
5248       ----------------
5249       -- Wide_Value --
5250       ----------------
5251
5252       --  We expand typ'Wide_Value (X) into
5253
5254       --    typ'Value
5255       --      (Wide_String_To_String (X, Wide_Character_Encoding_Method))
5256
5257       --  Wide_String_To_String is a runtime function that converts its wide
5258       --  string argument to String, converting any non-translatable characters
5259       --  into appropriate escape sequences. This preserves the required
5260       --  semantics of Wide_Value in all cases, and results in a very simple
5261       --  implementation approach.
5262
5263       --  Note: for this approach to be fully standard compliant for the cases
5264       --  where typ is Wide_Character and Wide_Wide_Character, the encoding
5265       --  method must cover the entire character range (e.g. UTF-8). But that
5266       --  is a reasonable requirement when dealing with encoded character
5267       --  sequences. Presumably if one of the restrictive encoding mechanisms
5268       --  is in use such as Shift-JIS, then characters that cannot be
5269       --  represented using this encoding will not appear in any case.
5270
5271       when Attribute_Wide_Value => Wide_Value :
5272       begin
5273          Rewrite (N,
5274            Make_Attribute_Reference (Loc,
5275              Prefix         => Pref,
5276              Attribute_Name => Name_Value,
5277
5278              Expressions    => New_List (
5279                Make_Function_Call (Loc,
5280                  Name =>
5281                    New_Reference_To (RTE (RE_Wide_String_To_String), Loc),
5282
5283                  Parameter_Associations => New_List (
5284                    Relocate_Node (First (Exprs)),
5285                    Make_Integer_Literal (Loc,
5286                      Intval => Int (Wide_Character_Encoding_Method)))))));
5287
5288          Analyze_And_Resolve (N, Typ);
5289       end Wide_Value;
5290
5291       ---------------------
5292       -- Wide_Wide_Value --
5293       ---------------------
5294
5295       --  We expand typ'Wide_Value_Value (X) into
5296
5297       --    typ'Value
5298       --      (Wide_Wide_String_To_String (X, Wide_Character_Encoding_Method))
5299
5300       --  Wide_Wide_String_To_String is a runtime function that converts its
5301       --  wide string argument to String, converting any non-translatable
5302       --  characters into appropriate escape sequences. This preserves the
5303       --  required semantics of Wide_Wide_Value in all cases, and results in a
5304       --  very simple implementation approach.
5305
5306       --  It's not quite right where typ = Wide_Wide_Character, because the
5307       --  encoding method may not cover the whole character type ???
5308
5309       when Attribute_Wide_Wide_Value => Wide_Wide_Value :
5310       begin
5311          Rewrite (N,
5312            Make_Attribute_Reference (Loc,
5313              Prefix         => Pref,
5314              Attribute_Name => Name_Value,
5315
5316              Expressions    => New_List (
5317                Make_Function_Call (Loc,
5318                  Name =>
5319                    New_Reference_To (RTE (RE_Wide_Wide_String_To_String), Loc),
5320
5321                  Parameter_Associations => New_List (
5322                    Relocate_Node (First (Exprs)),
5323                    Make_Integer_Literal (Loc,
5324                      Intval => Int (Wide_Character_Encoding_Method)))))));
5325
5326          Analyze_And_Resolve (N, Typ);
5327       end Wide_Wide_Value;
5328
5329       ---------------------
5330       -- Wide_Wide_Width --
5331       ---------------------
5332
5333       --  Wide_Wide_Width attribute is handled in separate unit Exp_Imgv
5334
5335       when Attribute_Wide_Wide_Width =>
5336          Exp_Imgv.Expand_Width_Attribute (N, Wide_Wide);
5337
5338       ----------------
5339       -- Wide_Width --
5340       ----------------
5341
5342       --  Wide_Width attribute is handled in separate unit Exp_Imgv
5343
5344       when Attribute_Wide_Width =>
5345          Exp_Imgv.Expand_Width_Attribute (N, Wide);
5346
5347       -----------
5348       -- Width --
5349       -----------
5350
5351       --  Width attribute is handled in separate unit Exp_Imgv
5352
5353       when Attribute_Width =>
5354          Exp_Imgv.Expand_Width_Attribute (N, Normal);
5355
5356       -----------
5357       -- Write --
5358       -----------
5359
5360       when Attribute_Write => Write : declare
5361          P_Type : constant Entity_Id := Entity (Pref);
5362          U_Type : constant Entity_Id := Underlying_Type (P_Type);
5363          Pname  : Entity_Id;
5364          Decl   : Node_Id;
5365          Prag   : Node_Id;
5366          Arg3   : Node_Id;
5367          Wfunc  : Node_Id;
5368
5369       begin
5370          --  If no underlying type, we have an error that will be diagnosed
5371          --  elsewhere, so here we just completely ignore the expansion.
5372
5373          if No (U_Type) then
5374             return;
5375          end if;
5376
5377          --  The simple case, if there is a TSS for Write, just call it
5378
5379          Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
5380
5381          if Present (Pname) then
5382             null;
5383
5384          else
5385             --  If there is a Stream_Convert pragma, use it, we rewrite
5386
5387             --     sourcetyp'Output (stream, Item)
5388
5389             --  as
5390
5391             --     strmtyp'Output (Stream, strmwrite (acttyp (Item)));
5392
5393             --  where strmwrite is the given Write function that converts an
5394             --  argument of type sourcetyp or a type acctyp, from which it is
5395             --  derived to type strmtyp. The conversion to acttyp is required
5396             --  for the derived case.
5397
5398             Prag := Get_Stream_Convert_Pragma (P_Type);
5399
5400             if Present (Prag) then
5401                Arg3 :=
5402                  Next (Next (First (Pragma_Argument_Associations (Prag))));
5403                Wfunc := Entity (Expression (Arg3));
5404
5405                Rewrite (N,
5406                  Make_Attribute_Reference (Loc,
5407                    Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
5408                    Attribute_Name => Name_Output,
5409                    Expressions => New_List (
5410                      Relocate_Node (First (Exprs)),
5411                      Make_Function_Call (Loc,
5412                        Name => New_Occurrence_Of (Wfunc, Loc),
5413                        Parameter_Associations => New_List (
5414                          OK_Convert_To (Etype (First_Formal (Wfunc)),
5415                            Relocate_Node (Next (First (Exprs)))))))));
5416
5417                Analyze (N);
5418                return;
5419
5420             --  For elementary types, we call the W_xxx routine directly
5421
5422             elsif Is_Elementary_Type (U_Type) then
5423                Rewrite (N, Build_Elementary_Write_Call (N));
5424                Analyze (N);
5425                return;
5426
5427             --  Array type case
5428
5429             elsif Is_Array_Type (U_Type) then
5430                Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
5431                Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
5432
5433             --  Tagged type case, use the primitive Write function. Note that
5434             --  this will dispatch in the class-wide case which is what we want
5435
5436             elsif Is_Tagged_Type (U_Type) then
5437                Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
5438
5439             --  All other record type cases, including protected records.
5440             --  The latter only arise for expander generated code for
5441             --  handling shared passive partition access.
5442
5443             else
5444                pragma Assert
5445                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
5446
5447                --  Ada 2005 (AI-216): Program_Error is raised when executing
5448                --  the default implementation of the Write attribute of an
5449                --  Unchecked_Union type. However, if the 'Write reference is
5450                --  within the generated Output stream procedure, Write outputs
5451                --  the components, and the default values of the discriminant
5452                --  are streamed by the Output procedure itself.
5453
5454                if Is_Unchecked_Union (Base_Type (U_Type))
5455                  and not Is_TSS (Current_Scope, TSS_Stream_Output)
5456                then
5457                   Insert_Action (N,
5458                     Make_Raise_Program_Error (Loc,
5459                       Reason => PE_Unchecked_Union_Restriction));
5460                end if;
5461
5462                if Has_Discriminants (U_Type)
5463                  and then Present
5464                    (Discriminant_Default_Value (First_Discriminant (U_Type)))
5465                then
5466                   Build_Mutable_Record_Write_Procedure
5467                     (Loc, Full_Base (U_Type), Decl, Pname);
5468                else
5469                   Build_Record_Write_Procedure
5470                     (Loc, Full_Base (U_Type), Decl, Pname);
5471                end if;
5472
5473                Insert_Action (N, Decl);
5474             end if;
5475          end if;
5476
5477          --  If we fall through, Pname is the procedure to be called
5478
5479          Rewrite_Stream_Proc_Call (Pname);
5480       end Write;
5481
5482       --  Component_Size is handled by the back end, unless the component size
5483       --  is known at compile time, which is always true in the packed array
5484       --  case. It is important that the packed array case is handled in the
5485       --  front end (see Eval_Attribute) since the back end would otherwise get
5486       --  confused by the equivalent packed array type.
5487
5488       when Attribute_Component_Size =>
5489          null;
5490
5491       --  The following attributes are handled by the back end (except that
5492       --  static cases have already been evaluated during semantic processing,
5493       --  but in any case the back end should not count on this). The one bit
5494       --  of special processing required is that these attributes typically
5495       --  generate conditionals in the code, so we need to check the relevant
5496       --  restriction.
5497
5498       when Attribute_Max                          |
5499            Attribute_Min                          =>
5500          Check_Restriction (No_Implicit_Conditionals, N);
5501
5502       --  The following attributes are handled by the back end (except that
5503       --  static cases have already been evaluated during semantic processing,
5504       --  but in any case the back end should not count on this).
5505
5506       --  The back end also handles the non-class-wide cases of Size
5507
5508       when Attribute_Bit_Order                    |
5509            Attribute_Code_Address                 |
5510            Attribute_Definite                     |
5511            Attribute_Null_Parameter               |
5512            Attribute_Passed_By_Reference          |
5513            Attribute_Pool_Address                 =>
5514          null;
5515
5516       --  The following attributes are also handled by the back end, but return
5517       --  a universal integer result, so may need a conversion for checking
5518       --  that the result is in range.
5519
5520       when Attribute_Aft                          |
5521            Attribute_Max_Alignment_For_Allocation |
5522            Attribute_Max_Size_In_Storage_Elements =>
5523          Apply_Universal_Integer_Attribute_Checks (N);
5524
5525       --  The following attributes should not appear at this stage, since they
5526       --  have already been handled by the analyzer (and properly rewritten
5527       --  with corresponding values or entities to represent the right values)
5528
5529       when Attribute_Abort_Signal                 |
5530            Attribute_Address_Size                 |
5531            Attribute_Base                         |
5532            Attribute_Class                        |
5533            Attribute_Compiler_Version             |
5534            Attribute_Default_Bit_Order            |
5535            Attribute_Delta                        |
5536            Attribute_Denorm                       |
5537            Attribute_Digits                       |
5538            Attribute_Emax                         |
5539            Attribute_Enabled                      |
5540            Attribute_Epsilon                      |
5541            Attribute_Fast_Math                    |
5542            Attribute_Has_Access_Values            |
5543            Attribute_Has_Discriminants            |
5544            Attribute_Has_Tagged_Values            |
5545            Attribute_Large                        |
5546            Attribute_Machine_Emax                 |
5547            Attribute_Machine_Emin                 |
5548            Attribute_Machine_Mantissa             |
5549            Attribute_Machine_Overflows            |
5550            Attribute_Machine_Radix                |
5551            Attribute_Machine_Rounds               |
5552            Attribute_Maximum_Alignment            |
5553            Attribute_Model_Emin                   |
5554            Attribute_Model_Epsilon                |
5555            Attribute_Model_Mantissa               |
5556            Attribute_Model_Small                  |
5557            Attribute_Modulus                      |
5558            Attribute_Partition_ID                 |
5559            Attribute_Range                        |
5560            Attribute_Safe_Emax                    |
5561            Attribute_Safe_First                   |
5562            Attribute_Safe_Large                   |
5563            Attribute_Safe_Last                    |
5564            Attribute_Safe_Small                   |
5565            Attribute_Scale                        |
5566            Attribute_Signed_Zeros                 |
5567            Attribute_Small                        |
5568            Attribute_Storage_Unit                 |
5569            Attribute_Stub_Type                    |
5570            Attribute_System_Allocator_Alignment   |
5571            Attribute_Target_Name                  |
5572            Attribute_Type_Class                   |
5573            Attribute_Type_Key                     |
5574            Attribute_Unconstrained_Array          |
5575            Attribute_Universal_Literal_String     |
5576            Attribute_Wchar_T_Size                 |
5577            Attribute_Word_Size                    =>
5578          raise Program_Error;
5579
5580       --  The Asm_Input and Asm_Output attributes are not expanded at this
5581       --  stage, but will be eliminated in the expansion of the Asm call, see
5582       --  Exp_Intr for details. So the back end will never see these either.
5583
5584       when Attribute_Asm_Input                    |
5585            Attribute_Asm_Output                   =>
5586          null;
5587       end case;
5588
5589    exception
5590       when RE_Not_Available =>
5591          return;
5592    end Expand_N_Attribute_Reference;
5593
5594    ----------------------
5595    -- Expand_Pred_Succ --
5596    ----------------------
5597
5598    --  For typ'Pred (exp), we generate the check
5599
5600    --    [constraint_error when exp = typ'Base'First]
5601
5602    --  Similarly, for typ'Succ (exp), we generate the check
5603
5604    --    [constraint_error when exp = typ'Base'Last]
5605
5606    --  These checks are not generated for modular types, since the proper
5607    --  semantics for Succ and Pred on modular types is to wrap, not raise CE.
5608    --  We also suppress these checks if we are the right side of an assignment
5609    --  statement or the expression of an object declaration, where the flag
5610    --  Suppress_Assignment_Checks is set for the assignment/declaration.
5611
5612    procedure Expand_Pred_Succ (N : Node_Id) is
5613       Loc  : constant Source_Ptr := Sloc (N);
5614       P    : constant Node_Id    := Parent (N);
5615       Cnam : Name_Id;
5616
5617    begin
5618       if Attribute_Name (N) = Name_Pred then
5619          Cnam := Name_First;
5620       else
5621          Cnam := Name_Last;
5622       end if;
5623
5624       if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration)
5625         or else not Suppress_Assignment_Checks (P)
5626       then
5627          Insert_Action (N,
5628            Make_Raise_Constraint_Error (Loc,
5629              Condition =>
5630                Make_Op_Eq (Loc,
5631                  Left_Opnd =>
5632                    Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
5633                  Right_Opnd =>
5634                    Make_Attribute_Reference (Loc,
5635                      Prefix =>
5636                        New_Reference_To (Base_Type (Etype (Prefix (N))), Loc),
5637                      Attribute_Name => Cnam)),
5638              Reason => CE_Overflow_Check_Failed));
5639       end if;
5640    end Expand_Pred_Succ;
5641
5642    -------------------
5643    -- Find_Fat_Info --
5644    -------------------
5645
5646    procedure Find_Fat_Info
5647      (T        : Entity_Id;
5648       Fat_Type : out Entity_Id;
5649       Fat_Pkg  : out RE_Id)
5650    is
5651       Btyp : constant Entity_Id := Base_Type (T);
5652       Rtyp : constant Entity_Id := Root_Type (T);
5653       Digs : constant Nat       := UI_To_Int (Digits_Value (Btyp));
5654
5655    begin
5656       --  If the base type is VAX float, then get appropriate VAX float type
5657
5658       if Vax_Float (Btyp) then
5659          case Digs is
5660             when 6 =>
5661                Fat_Type := RTE (RE_Fat_VAX_F);
5662                Fat_Pkg  := RE_Attr_VAX_F_Float;
5663
5664             when 9 =>
5665                Fat_Type := RTE (RE_Fat_VAX_D);
5666                Fat_Pkg  := RE_Attr_VAX_D_Float;
5667
5668             when 15 =>
5669                Fat_Type := RTE (RE_Fat_VAX_G);
5670                Fat_Pkg  := RE_Attr_VAX_G_Float;
5671
5672             when others =>
5673                raise Program_Error;
5674          end case;
5675
5676       --  If root type is VAX float, this is the case where the library has
5677       --  been recompiled in VAX float mode, and we have an IEEE float type.
5678       --  This is when we use the special IEEE Fat packages.
5679
5680       elsif Vax_Float (Rtyp) then
5681          case Digs is
5682             when 6 =>
5683                Fat_Type := RTE (RE_Fat_IEEE_Short);
5684                Fat_Pkg  := RE_Attr_IEEE_Short;
5685
5686             when 15 =>
5687                Fat_Type := RTE (RE_Fat_IEEE_Long);
5688                Fat_Pkg  := RE_Attr_IEEE_Long;
5689
5690             when others =>
5691                raise Program_Error;
5692          end case;
5693
5694       --  If neither the base type nor the root type is VAX_Native then VAX
5695       --  float is out of the picture, and we can just use the root type.
5696
5697       else
5698          Fat_Type := Rtyp;
5699
5700          if Fat_Type = Standard_Short_Float then
5701             Fat_Pkg := RE_Attr_Short_Float;
5702
5703          elsif Fat_Type = Standard_Float then
5704             Fat_Pkg := RE_Attr_Float;
5705
5706          elsif Fat_Type = Standard_Long_Float then
5707             Fat_Pkg := RE_Attr_Long_Float;
5708
5709          elsif Fat_Type = Standard_Long_Long_Float then
5710             Fat_Pkg := RE_Attr_Long_Long_Float;
5711
5712          --  Universal real (which is its own root type) is treated as being
5713          --  equivalent to Standard.Long_Long_Float, since it is defined to
5714          --  have the same precision as the longest Float type.
5715
5716          elsif Fat_Type = Universal_Real then
5717             Fat_Type := Standard_Long_Long_Float;
5718             Fat_Pkg := RE_Attr_Long_Long_Float;
5719
5720          else
5721             raise Program_Error;
5722          end if;
5723       end if;
5724    end Find_Fat_Info;
5725
5726    ----------------------------
5727    -- Find_Stream_Subprogram --
5728    ----------------------------
5729
5730    function Find_Stream_Subprogram
5731      (Typ : Entity_Id;
5732       Nam : TSS_Name_Type) return Entity_Id
5733    is
5734       Base_Typ : constant Entity_Id := Base_Type (Typ);
5735       Ent      : constant Entity_Id := TSS (Typ, Nam);
5736
5737       function Is_Available (Entity : RE_Id) return Boolean;
5738       pragma Inline (Is_Available);
5739       --  Function to check whether the specified run-time call is available
5740       --  in the run time used. In the case of a configurable run time, it
5741       --  is normal that some subprograms are not there.
5742
5743       --  I don't understand this routine at all, why is this not just a
5744       --  call to RTE_Available? And if for some reason we need a different
5745       --  routine with different semantics, why is not in Rtsfind ???
5746
5747       ------------------
5748       -- Is_Available --
5749       ------------------
5750
5751       function Is_Available (Entity : RE_Id) return Boolean is
5752       begin
5753          --  Assume that the unit will always be available when using a
5754          --  "normal" (not configurable) run time.
5755
5756          return not Configurable_Run_Time_Mode
5757            or else RTE_Available (Entity);
5758       end Is_Available;
5759
5760    --  Start of processing for Find_Stream_Subprogram
5761
5762    begin
5763       if Present (Ent) then
5764          return Ent;
5765       end if;
5766
5767       --  Stream attributes for strings are expanded into library calls. The
5768       --  following checks are disabled when the run-time is not available or
5769       --  when compiling predefined types due to bootstrap issues. As a result,
5770       --  the compiler will generate in-place stream routines for string types
5771       --  that appear in GNAT's library, but will generate calls via rtsfind
5772       --  to library routines for user code.
5773
5774       --  ??? For now, disable this code for JVM, since this generates a
5775       --  VerifyError exception at run time on e.g. c330001.
5776
5777       --  This is disabled for AAMP, to avoid creating dependences on files not
5778       --  supported in the AAMP library (such as s-fileio.adb).
5779
5780       --  Note: In the case of using a configurable run time, it is very likely
5781       --  that stream routines for string types are not present (they require
5782       --  file system support). In this case, the specific stream routines for
5783       --  strings are not used, relying on the regular stream mechanism
5784       --  instead. That is why we include the test Is_Available when dealing
5785       --  with these cases.
5786
5787       if VM_Target /= JVM_Target
5788         and then not AAMP_On_Target
5789         and then
5790           not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
5791       then
5792          --  String as defined in package Ada
5793
5794          if Base_Typ = Standard_String then
5795             if Restriction_Active (No_Stream_Optimizations) then
5796                if Nam = TSS_Stream_Input
5797                  and then Is_Available (RE_String_Input)
5798                then
5799                   return RTE (RE_String_Input);
5800
5801                elsif Nam = TSS_Stream_Output
5802                  and then Is_Available (RE_String_Output)
5803                then
5804                   return RTE (RE_String_Output);
5805
5806                elsif Nam = TSS_Stream_Read
5807                  and then Is_Available (RE_String_Read)
5808                then
5809                   return RTE (RE_String_Read);
5810
5811                elsif Nam = TSS_Stream_Write
5812                  and then Is_Available (RE_String_Write)
5813                then
5814                   return RTE (RE_String_Write);
5815
5816                elsif Nam /= TSS_Stream_Input and then
5817                      Nam /= TSS_Stream_Output and then
5818                      Nam /= TSS_Stream_Read and then
5819                      Nam /= TSS_Stream_Write
5820                then
5821                   raise Program_Error;
5822                end if;
5823
5824             else
5825                if Nam = TSS_Stream_Input
5826                  and then Is_Available (RE_String_Input_Blk_IO)
5827                then
5828                   return RTE (RE_String_Input_Blk_IO);
5829
5830                elsif Nam = TSS_Stream_Output
5831                  and then Is_Available (RE_String_Output_Blk_IO)
5832                then
5833                   return RTE (RE_String_Output_Blk_IO);
5834
5835                elsif Nam = TSS_Stream_Read
5836                  and then Is_Available (RE_String_Read_Blk_IO)
5837                then
5838                   return RTE (RE_String_Read_Blk_IO);
5839
5840                elsif Nam = TSS_Stream_Write
5841                  and then Is_Available (RE_String_Write_Blk_IO)
5842                then
5843                   return RTE (RE_String_Write_Blk_IO);
5844
5845                elsif Nam /= TSS_Stream_Input and then
5846                      Nam /= TSS_Stream_Output and then
5847                      Nam /= TSS_Stream_Read and then
5848                      Nam /= TSS_Stream_Write
5849                then
5850                   raise Program_Error;
5851                end if;
5852             end if;
5853
5854          --  Wide_String as defined in package Ada
5855
5856          elsif Base_Typ = Standard_Wide_String then
5857             if Restriction_Active (No_Stream_Optimizations) then
5858                if Nam = TSS_Stream_Input
5859                  and then Is_Available (RE_Wide_String_Input)
5860                then
5861                   return RTE (RE_Wide_String_Input);
5862
5863                elsif Nam = TSS_Stream_Output
5864                  and then Is_Available (RE_Wide_String_Output)
5865                then
5866                   return RTE (RE_Wide_String_Output);
5867
5868                elsif Nam = TSS_Stream_Read
5869                  and then Is_Available (RE_Wide_String_Read)
5870                then
5871                   return RTE (RE_Wide_String_Read);
5872
5873                elsif Nam = TSS_Stream_Write
5874                  and then Is_Available (RE_Wide_String_Write)
5875                then
5876                   return RTE (RE_Wide_String_Write);
5877
5878                elsif Nam /= TSS_Stream_Input and then
5879                      Nam /= TSS_Stream_Output and then
5880                      Nam /= TSS_Stream_Read and then
5881                      Nam /= TSS_Stream_Write
5882                then
5883                   raise Program_Error;
5884                end if;
5885
5886             else
5887                if Nam = TSS_Stream_Input
5888                  and then Is_Available (RE_Wide_String_Input_Blk_IO)
5889                then
5890                   return RTE (RE_Wide_String_Input_Blk_IO);
5891
5892                elsif Nam = TSS_Stream_Output
5893                  and then Is_Available (RE_Wide_String_Output_Blk_IO)
5894                then
5895                   return RTE (RE_Wide_String_Output_Blk_IO);
5896
5897                elsif Nam = TSS_Stream_Read
5898                  and then Is_Available (RE_Wide_String_Read_Blk_IO)
5899                then
5900                   return RTE (RE_Wide_String_Read_Blk_IO);
5901
5902                elsif Nam = TSS_Stream_Write
5903                  and then Is_Available (RE_Wide_String_Write_Blk_IO)
5904                then
5905                   return RTE (RE_Wide_String_Write_Blk_IO);
5906
5907                elsif Nam /= TSS_Stream_Input and then
5908                      Nam /= TSS_Stream_Output and then
5909                      Nam /= TSS_Stream_Read and then
5910                      Nam /= TSS_Stream_Write
5911                then
5912                   raise Program_Error;
5913                end if;
5914             end if;
5915
5916          --  Wide_Wide_String as defined in package Ada
5917
5918          elsif Base_Typ = Standard_Wide_Wide_String then
5919             if Restriction_Active (No_Stream_Optimizations) then
5920                if Nam = TSS_Stream_Input
5921                  and then Is_Available (RE_Wide_Wide_String_Input)
5922                then
5923                   return RTE (RE_Wide_Wide_String_Input);
5924
5925                elsif Nam = TSS_Stream_Output
5926                  and then Is_Available (RE_Wide_Wide_String_Output)
5927                then
5928                   return RTE (RE_Wide_Wide_String_Output);
5929
5930                elsif Nam = TSS_Stream_Read
5931                  and then Is_Available (RE_Wide_Wide_String_Read)
5932                then
5933                   return RTE (RE_Wide_Wide_String_Read);
5934
5935                elsif Nam = TSS_Stream_Write
5936                  and then Is_Available (RE_Wide_Wide_String_Write)
5937                then
5938                   return RTE (RE_Wide_Wide_String_Write);
5939
5940                elsif Nam /= TSS_Stream_Input and then
5941                      Nam /= TSS_Stream_Output and then
5942                      Nam /= TSS_Stream_Read and then
5943                      Nam /= TSS_Stream_Write
5944                then
5945                   raise Program_Error;
5946                end if;
5947
5948             else
5949                if Nam = TSS_Stream_Input
5950                  and then Is_Available (RE_Wide_Wide_String_Input_Blk_IO)
5951                then
5952                   return RTE (RE_Wide_Wide_String_Input_Blk_IO);
5953
5954                elsif Nam = TSS_Stream_Output
5955                  and then Is_Available (RE_Wide_Wide_String_Output_Blk_IO)
5956                then
5957                   return RTE (RE_Wide_Wide_String_Output_Blk_IO);
5958
5959                elsif Nam = TSS_Stream_Read
5960                  and then Is_Available (RE_Wide_Wide_String_Read_Blk_IO)
5961                then
5962                   return RTE (RE_Wide_Wide_String_Read_Blk_IO);
5963
5964                elsif Nam = TSS_Stream_Write
5965                  and then Is_Available (RE_Wide_Wide_String_Write_Blk_IO)
5966                then
5967                   return RTE (RE_Wide_Wide_String_Write_Blk_IO);
5968
5969                elsif Nam /= TSS_Stream_Input and then
5970                      Nam /= TSS_Stream_Output and then
5971                      Nam /= TSS_Stream_Read and then
5972                      Nam /= TSS_Stream_Write
5973                then
5974                   raise Program_Error;
5975                end if;
5976             end if;
5977          end if;
5978       end if;
5979
5980       if Is_Tagged_Type (Typ)
5981         and then Is_Derived_Type (Typ)
5982       then
5983          return Find_Prim_Op (Typ, Nam);
5984       else
5985          return Find_Inherited_TSS (Typ, Nam);
5986       end if;
5987    end Find_Stream_Subprogram;
5988
5989    ---------------
5990    -- Full_Base --
5991    ---------------
5992
5993    function Full_Base (T : Entity_Id) return Entity_Id is
5994       BT : Entity_Id;
5995
5996    begin
5997       BT := Base_Type (T);
5998
5999       if Is_Private_Type (BT)
6000         and then Present (Full_View (BT))
6001       then
6002          BT := Full_View (BT);
6003       end if;
6004
6005       return BT;
6006    end Full_Base;
6007
6008    -----------------------
6009    -- Get_Index_Subtype --
6010    -----------------------
6011
6012    function Get_Index_Subtype (N : Node_Id) return Node_Id is
6013       P_Type : Entity_Id := Etype (Prefix (N));
6014       Indx   : Node_Id;
6015       J      : Int;
6016
6017    begin
6018       if Is_Access_Type (P_Type) then
6019          P_Type := Designated_Type (P_Type);
6020       end if;
6021
6022       if No (Expressions (N)) then
6023          J := 1;
6024       else
6025          J := UI_To_Int (Expr_Value (First (Expressions (N))));
6026       end if;
6027
6028       Indx := First_Index (P_Type);
6029       while J > 1 loop
6030          Next_Index (Indx);
6031          J := J - 1;
6032       end loop;
6033
6034       return Etype (Indx);
6035    end Get_Index_Subtype;
6036
6037    -------------------------------
6038    -- Get_Stream_Convert_Pragma --
6039    -------------------------------
6040
6041    function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is
6042       Typ : Entity_Id;
6043       N   : Node_Id;
6044
6045    begin
6046       --  Note: we cannot use Get_Rep_Pragma here because of the peculiarity
6047       --  that a stream convert pragma for a tagged type is not inherited from
6048       --  its parent. Probably what is wrong here is that it is basically
6049       --  incorrect to consider a stream convert pragma to be a representation
6050       --  pragma at all ???
6051
6052       N := First_Rep_Item (Implementation_Base_Type (T));
6053       while Present (N) loop
6054          if Nkind (N) = N_Pragma
6055            and then Pragma_Name (N) = Name_Stream_Convert
6056          then
6057             --  For tagged types this pragma is not inherited, so we
6058             --  must verify that it is defined for the given type and
6059             --  not an ancestor.
6060
6061             Typ :=
6062               Entity (Expression (First (Pragma_Argument_Associations (N))));
6063
6064             if not Is_Tagged_Type (T)
6065               or else T = Typ
6066               or else (Is_Private_Type (Typ) and then T = Full_View (Typ))
6067             then
6068                return N;
6069             end if;
6070          end if;
6071
6072          Next_Rep_Item (N);
6073       end loop;
6074
6075       return Empty;
6076    end Get_Stream_Convert_Pragma;
6077
6078    ---------------------------------
6079    -- Is_Constrained_Packed_Array --
6080    ---------------------------------
6081
6082    function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is
6083       Arr : Entity_Id := Typ;
6084
6085    begin
6086       if Is_Access_Type (Arr) then
6087          Arr := Designated_Type (Arr);
6088       end if;
6089
6090       return Is_Array_Type (Arr)
6091         and then Is_Constrained (Arr)
6092         and then Present (Packed_Array_Type (Arr));
6093    end Is_Constrained_Packed_Array;
6094
6095    ----------------------------------------
6096    -- Is_Inline_Floating_Point_Attribute --
6097    ----------------------------------------
6098
6099    function Is_Inline_Floating_Point_Attribute (N : Node_Id) return Boolean is
6100       Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
6101
6102    begin
6103       if Nkind (Parent (N)) /= N_Type_Conversion
6104         or else not Is_Integer_Type (Etype (Parent (N)))
6105       then
6106          return False;
6107       end if;
6108
6109       --  Should also support 'Machine_Rounding and 'Unbiased_Rounding, but
6110       --  required back end support has not been implemented yet ???
6111
6112       return Id = Attribute_Truncation;
6113    end Is_Inline_Floating_Point_Attribute;
6114
6115 end Exp_Attr;