gcc/ada/exp_attr.adb

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