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