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