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