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