gcc/ada/exp_attr.adb

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