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