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