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