gcc/ada/exp_attr.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ A T T R                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2004 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Einfo;    use Einfo;
  30 with Elists;   use Elists;
  31 with Exp_Ch2;  use Exp_Ch2;
  32 with Exp_Ch9;  use Exp_Ch9;
  33 with Exp_Imgv; use Exp_Imgv;
  34 with Exp_Pakd; use Exp_Pakd;
  35 with Exp_Strm; use Exp_Strm;
  36 with Exp_Tss;  use Exp_Tss;
  37 with Exp_Util; use Exp_Util;
  38 with Gnatvsn;  use Gnatvsn;
  39 with Hostparm; use Hostparm;
  40 with Lib;      use Lib;
  41 with Namet;    use Namet;
  42 with Nmake;    use Nmake;
  43 with Nlists;   use Nlists;
  44 with Opt;      use Opt;
  45 with Restrict; use Restrict;
  46 with Rident;   use Rident;
  47 with Rtsfind;  use Rtsfind;
  48 with Sem;      use Sem;
  49 with Sem_Ch7;  use Sem_Ch7;
  50 with Sem_Ch8;  use Sem_Ch8;
  51 with Sem_Eval; use Sem_Eval;
  52 with Sem_Res;  use Sem_Res;
  53 with Sem_Util; use Sem_Util;
  54 with Sinfo;    use Sinfo;
  55 with Snames;   use Snames;
  56 with Stand;    use Stand;
  57 with Stringt;  use Stringt;
  58 with Tbuild;   use Tbuild;
  59 with Ttypes;   use Ttypes;
  60 with Uintp;    use Uintp;
  61 with Uname;    use Uname;
  62 with Validsw;  use Validsw;
  63
  64 package body Exp_Attr is
  65
  66    -----------------------
  67    -- Local Subprograms --
  68    -----------------------
  69
  70    procedure Compile_Stream_Body_In_Scope
  71      (N     : Node_Id;
  72       Decl  : Node_Id;
  73       Arr   : Entity_Id;
  74       Check : Boolean);
  75    --  The body for a stream subprogram may be generated outside of the scope
  76    --  of the type. If the type is fully private, it may depend on the full
  77    --  view of other types (e.g. indices) that are currently private as well.
  78    --  We install the declarations of the package in which the type is declared
  79    --  before compiling the body in what is its proper environment. The Check
  80    --  parameter indicates if checks are to be suppressed for the stream body.
  81    --  We suppress checks for array/record reads, since the rule is that these
  82    --  are like assignments, out of range values due to uninitialized storage,
  83    --  or other invalid values do NOT cause a Constraint_Error to be raised.
  84
  85    procedure Expand_Fpt_Attribute
  86      (N    : Node_Id;
  87       Rtp  : Entity_Id;
  88       Nam  : Name_Id;
  89       Args : List_Id);
  90    --  This procedure expands a call to a floating-point attribute function.
  91    --  N is the attribute reference node, and Args is a list of arguments to
  92    --  be passed to the function call. Rtp is the root type of the floating
  93    --  point type involved (used to select the proper generic instantiation
  94    --  of the package containing the attribute routines). The Nam argument
  95    --  is the attribute processing routine to be called. This is normally
  96    --  the same as the attribute name, except in the Unaligned_Valid case.
  97
  98    procedure Expand_Fpt_Attribute_R (N : Node_Id);
  99    --  This procedure expands a call to a floating-point attribute function
 100    --  that takes a single floating-point argument. The function to be called
 101    --  is always the same as the attribute name.
 102
 103    procedure Expand_Fpt_Attribute_RI (N : Node_Id);
 104    --  This procedure expands a call to a floating-point attribute function
 105    --  that takes one floating-point argument and one integer argument. The
 106    --  function to be called is always the same as the attribute name.
 107
 108    procedure Expand_Fpt_Attribute_RR (N : Node_Id);
 109    --  This procedure expands a call to a floating-point attribute function
 110    --  that takes two floating-point arguments. The function to be called
 111    --  is always the same as the attribute name.
 112
 113    procedure Expand_Pred_Succ (N : Node_Id);
 114    --  Handles expansion of Pred or Succ attributes for case of non-real
 115    --  operand with overflow checking required.
 116
 117    function Get_Index_Subtype (N : Node_Id) return Entity_Id;
 118    --  Used for Last, Last, and Length, when the prefix is an array type,
 119    --  Obtains the corresponding index subtype.
 120
 121    procedure Expand_Access_To_Type (N : Node_Id);
 122    --  A reference to a type within its own scope is resolved to a reference
 123    --  to the current instance of the type in its initialization procedure.
 124
 125    function Find_Inherited_TSS
 126      (Typ : Entity_Id;
 127       Nam : TSS_Name_Type) return Entity_Id;
 128    --  Returns the TSS of name Nam of Typ, or of its closest ancestor defining
 129    --  such a TSS. Empty is returned is neither Typ nor any of its ancestors
 130    --  have such a TSS.
 131
 132    function Find_Stream_Subprogram
 133      (Typ : Entity_Id;
 134       Nam : TSS_Name_Type) return Entity_Id;
 135    --  Returns the stream-oriented subprogram attribute for Typ. For tagged
 136    --  types, the corresponding primitive operation is looked up, else the
 137    --  appropriate TSS from the type itself, or from its closest ancestor
 138    --  defining it, is returned. In both cases, inheritance of representation
 139    --  aspects is thus taken into account.
 140
 141    function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean;
 142    --  Utility for array attributes, returns true on packed constrained
 143    --  arrays, and on access to same.
 144
 145    ----------------------------------
 146    -- Compile_Stream_Body_In_Scope --
 147    ----------------------------------
 148
 149    procedure Compile_Stream_Body_In_Scope
 150      (N     : Node_Id;
 151       Decl  : Node_Id;
 152       Arr   : Entity_Id;
 153       Check : Boolean)
 154    is
 155       Installed : Boolean := False;
 156       Scop      : constant Entity_Id := Scope (Arr);
 157       Curr      : constant Entity_Id := Current_Scope;
 158
 159    begin
 160       if Is_Hidden (Arr)
 161         and then not In_Open_Scopes (Scop)
 162         and then Ekind (Scop) = E_Package
 163       then
 164          New_Scope (Scop);
 165          Install_Visible_Declarations (Scop);
 166          Install_Private_Declarations (Scop);
 167          Installed := True;
 168
 169          --  The entities in the package are now visible, but the generated
 170          --  stream entity must appear in the current scope (usually an
 171          --  enclosing stream function) so that itypes all have their proper
 172          --  scopes.
 173
 174          New_Scope (Curr);
 175       end if;
 176
 177       if Check then
 178          Insert_Action (N, Decl);
 179       else
 180          Insert_Action (N, Decl, All_Checks);
 181       end if;
 182
 183       if Installed then
 184
 185          --  Remove extra copy of current scope, and package itself
 186
 187          Pop_Scope;
 188          End_Package_Scope (Scop);
 189       end if;
 190    end Compile_Stream_Body_In_Scope;
 191
 192    ---------------------------
 193    -- Expand_Access_To_Type --
 194    ---------------------------
 195
 196    procedure Expand_Access_To_Type (N : Node_Id) is
 197       Loc    : constant Source_Ptr   := Sloc (N);
 198       Typ    : constant Entity_Id    := Etype (N);
 199       Pref   : constant Node_Id      := Prefix (N);
 200       Par    : Node_Id;
 201       Formal : Entity_Id;
 202
 203    begin
 204       if Is_Entity_Name (Pref)
 205         and then Is_Type (Entity (Pref))
 206       then
 207          --  If the current instance name denotes a task type,
 208          --  then the access attribute is rewritten to be the
 209          --  name of the "_task" parameter associated with the
 210          --  task type's task body procedure. An unchecked
 211          --  conversion is applied to ensure a type match in
 212          --  cases of expander-generated calls (e.g., init procs).
 213
 214          if Is_Task_Type (Entity (Pref)) then
 215             Formal :=
 216               First_Entity (Get_Task_Body_Procedure (Entity (Pref)));
 217
 218             while Present (Formal) loop
 219                exit when Chars (Formal) = Name_uTask;
 220                Next_Entity (Formal);
 221             end loop;
 222
 223             pragma Assert (Present (Formal));
 224
 225             Rewrite (N,
 226               Unchecked_Convert_To (Typ, New_Occurrence_Of (Formal, Loc)));
 227             Set_Etype (N, Typ);
 228
 229          --  The expression must appear in a default expression,
 230          --  (which in the initialization procedure is the rhs of
 231          --  an assignment), and not in a discriminant constraint.
 232
 233          else
 234             Par := Parent (N);
 235
 236             while Present (Par) loop
 237                exit when Nkind (Par) = N_Assignment_Statement;
 238
 239                if Nkind (Par) = N_Component_Declaration then
 240                   return;
 241                end if;
 242
 243                Par := Parent (Par);
 244             end loop;
 245
 246             if Present (Par) then
 247                Rewrite (N,
 248                  Make_Attribute_Reference (Loc,
 249                    Prefix => Make_Identifier (Loc, Name_uInit),
 250                    Attribute_Name  => Attribute_Name (N)));
 251
 252                Analyze_And_Resolve (N, Typ);
 253             end if;
 254          end if;
 255       end if;
 256    end Expand_Access_To_Type;
 257
 258    --------------------------
 259    -- Expand_Fpt_Attribute --
 260    --------------------------
 261
 262    procedure Expand_Fpt_Attribute
 263      (N    : Node_Id;
 264       Rtp  : Entity_Id;
 265       Nam  : Name_Id;
 266       Args : List_Id)
 267    is
 268       Loc : constant Source_Ptr := Sloc (N);
 269       Typ : constant Entity_Id  := Etype (N);
 270       Pkg : RE_Id;
 271       Fnm : Node_Id;
 272
 273    begin
 274       --  The function name is the selected component Fat_xxx.yyy where xxx
 275       --  is the floating-point root type, and yyy is the argument Nam.
 276
 277       --  Note: it would be more usual to have separate RE entries for each
 278       --  of the entities in the Fat packages, but first they have identical
 279       --  names (so we would have to have lots of renaming declarations to
 280       --  meet the normal RE rule of separate names for all runtime entities),
 281       --  and second there would be an awful lot of them!
 282
 283       if Rtp = Standard_Short_Float then
 284          Pkg := RE_Fat_Short_Float;
 285       elsif Rtp = Standard_Float then
 286          Pkg := RE_Fat_Float;
 287       elsif Rtp = Standard_Long_Float then
 288          Pkg := RE_Fat_Long_Float;
 289       else
 290          Pkg := RE_Fat_Long_Long_Float;
 291       end if;
 292
 293       Fnm :=
 294         Make_Selected_Component (Loc,
 295           Prefix        => New_Reference_To (RTE (Pkg), Loc),
 296           Selector_Name => Make_Identifier (Loc, Nam));
 297
 298       --  The generated call is given the provided set of parameters, and then
 299       --  wrapped in a conversion which converts the result to the target type
 300
 301       Rewrite (N,
 302         Unchecked_Convert_To (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
 494
 495       if Validity_Checks_On and Validity_Check_Operands then
 496          declare
 497             Expr : Node_Id;
 498
 499          begin
 500             Expr := First (Expressions (N));
 501             while Present (Expr) loop
 502                Ensure_Valid (Expr);
 503                Next (Expr);
 504             end loop;
 505          end;
 506       end if;
 507
 508       --  Remaining processing depends on specific attribute
 509
 510       case Id is
 511
 512       ------------
 513       -- Access --
 514       ------------
 515
 516       when Attribute_Access =>
 517
 518          if Ekind (Btyp) = E_Access_Protected_Subprogram_Type then
 519
 520             --  The value of the attribute_reference is a record containing
 521             --  two fields: an access to the protected object, and an access
 522             --  to the subprogram itself. The prefix is a selected component.
 523
 524             declare
 525                Agg     : Node_Id;
 526                Sub     : Entity_Id;
 527                E_T     : constant Entity_Id := Equivalent_Type (Btyp);
 528                Acc     : constant Entity_Id :=
 529                            Etype (Next_Component (First_Component (E_T)));
 530                Obj_Ref : Node_Id;
 531                Curr    : Entity_Id;
 532
 533             begin
 534                --  Within the body of the protected type, the prefix
 535                --  designates a local operation, and the object is the first
 536                --  parameter of the corresponding protected body of the
 537                --  current enclosing operation.
 538
 539                if Is_Entity_Name (Pref) then
 540                   pragma Assert (In_Open_Scopes (Scope (Entity (Pref))));
 541                   Sub :=
 542                     New_Occurrence_Of
 543                       (Protected_Body_Subprogram (Entity (Pref)), Loc);
 544                   Curr := Current_Scope;
 545
 546                   while Scope (Curr) /= Scope (Entity (Pref)) loop
 547                      Curr := Scope (Curr);
 548                   end loop;
 549
 550                   Obj_Ref :=
 551                     Make_Attribute_Reference (Loc,
 552                       Prefix =>
 553                          New_Occurrence_Of
 554                            (First_Formal
 555                               (Protected_Body_Subprogram (Curr)), Loc),
 556                       Attribute_Name => Name_Address);
 557
 558                --  Case where the prefix is not an entity name. Find the
 559                --  version of the protected operation to be called from
 560                --  outside the protected object.
 561
 562                else
 563                   Sub :=
 564                     New_Occurrence_Of
 565                       (External_Subprogram
 566                         (Entity (Selector_Name (Pref))), Loc);
 567
 568                   Obj_Ref :=
 569                     Make_Attribute_Reference (Loc,
 570                       Prefix => Relocate_Node (Prefix (Pref)),
 571                         Attribute_Name => Name_Address);
 572                end if;
 573
 574                Agg :=
 575                  Make_Aggregate (Loc,
 576                    Expressions =>
 577                      New_List (
 578                        Obj_Ref,
 579                        Unchecked_Convert_To (Acc,
 580                          Make_Attribute_Reference (Loc,
 581                            Prefix => Sub,
 582                            Attribute_Name => Name_Address))));
 583
 584                Rewrite (N, Agg);
 585
 586                Analyze_And_Resolve (N, E_T);
 587
 588                --  For subsequent analysis,  the node must retain its type.
 589                --  The backend will replace it with the equivalent type where
 590                --  needed.
 591
 592                Set_Etype (N, Typ);
 593             end;
 594
 595          elsif Ekind (Btyp) = E_General_Access_Type then
 596             declare
 597                Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
 598                Parm_Ent   : Entity_Id;
 599                Conversion : Node_Id;
 600
 601             begin
 602                --  If the prefix of an Access attribute is a dereference of an
 603                --  access parameter (or a renaming of such a dereference) and
 604                --  the context is a general access type (but not an anonymous
 605                --  access type), then rewrite the attribute as a conversion of
 606                --  the access parameter to the context access type.  This will
 607                --  result in an accessibility check being performed, if needed.
 608
 609                --    (X.all'Access => Acc_Type (X))
 610
 611                if Nkind (Ref_Object) = N_Explicit_Dereference
 612                  and then Is_Entity_Name (Prefix (Ref_Object))
 613                then
 614                   Parm_Ent := Entity (Prefix (Ref_Object));
 615
 616                   if Ekind (Parm_Ent) in Formal_Kind
 617                     and then Ekind (Etype (Parm_Ent)) = E_Anonymous_Access_Type
 618                     and then Present (Extra_Accessibility (Parm_Ent))
 619                   then
 620                      Conversion :=
 621                         Convert_To (Typ, New_Copy_Tree (Prefix (Ref_Object)));
 622
 623                      Rewrite (N, Conversion);
 624                      Analyze_And_Resolve (N, Typ);
 625                   end if;
 626                end if;
 627             end;
 628
 629          --  If the prefix is a type name, this is a reference to the current
 630          --  instance of the type, within its initialization procedure.
 631
 632          else
 633             Expand_Access_To_Type (N);
 634          end if;
 635
 636       --------------
 637       -- Adjacent --
 638       --------------
 639
 640       --  Transforms 'Adjacent into a call to the floating-point attribute
 641       --  function Adjacent in Fat_xxx (where xxx is the root type)
 642
 643       when Attribute_Adjacent =>
 644          Expand_Fpt_Attribute_RR (N);
 645
 646       -------------
 647       -- Address --
 648       -------------
 649
 650       when Attribute_Address => Address : declare
 651          Task_Proc : Entity_Id;
 652
 653       begin
 654          --  If the prefix is a task or a task type, the useful address
 655          --  is that of the procedure for the task body, i.e. the actual
 656          --  program unit. We replace the original entity with that of
 657          --  the procedure.
 658
 659          if Is_Entity_Name (Pref)
 660            and then Is_Task_Type (Entity (Pref))
 661          then
 662             Task_Proc := Next_Entity (Root_Type (Etype (Pref)));
 663
 664             while Present (Task_Proc) loop
 665                exit when Ekind (Task_Proc) = E_Procedure
 666                  and then Etype (First_Formal (Task_Proc)) =
 667                                   Corresponding_Record_Type (Etype (Pref));
 668                Next_Entity (Task_Proc);
 669             end loop;
 670
 671             if Present (Task_Proc) then
 672                Set_Entity (Pref, Task_Proc);
 673                Set_Etype  (Pref, Etype (Task_Proc));
 674             end if;
 675
 676          --  Similarly, the address of a protected operation is the address
 677          --  of the corresponding protected body, regardless of the protected
 678          --  object from which it is selected.
 679
 680          elsif Nkind (Pref) = N_Selected_Component
 681            and then Is_Subprogram (Entity (Selector_Name (Pref)))
 682            and then Is_Protected_Type (Scope (Entity (Selector_Name (Pref))))
 683          then
 684             Rewrite (Pref,
 685               New_Occurrence_Of (
 686                 External_Subprogram (Entity (Selector_Name (Pref))), Loc));
 687
 688          elsif Nkind (Pref) = N_Explicit_Dereference
 689            and then Ekind (Etype (Pref)) = E_Subprogram_Type
 690            and then Convention (Etype (Pref)) = Convention_Protected
 691          then
 692             --  The prefix is be a dereference of an access_to_protected_
 693             --  subprogram. The desired address is the second component of
 694             --  the record that represents the access.
 695
 696             declare
 697                Addr : constant Entity_Id := Etype (N);
 698                Ptr  : constant Node_Id   := Prefix (Pref);
 699                T    : constant Entity_Id :=
 700                         Equivalent_Type (Base_Type (Etype (Ptr)));
 701
 702             begin
 703                Rewrite (N,
 704                  Unchecked_Convert_To (Addr,
 705                    Make_Selected_Component (Loc,
 706                      Prefix => Unchecked_Convert_To (T, Ptr),
 707                      Selector_Name => New_Occurrence_Of (
 708                        Next_Entity (First_Entity (T)), Loc))));
 709
 710                Analyze_And_Resolve (N, Addr);
 711             end;
 712          end if;
 713
 714          --  Deal with packed array reference, other cases are handled by gigi
 715
 716          if Involves_Packed_Array_Reference (Pref) then
 717             Expand_Packed_Address_Reference (N);
 718          end if;
 719       end Address;
 720
 721       ---------------
 722       -- Alignment --
 723       ---------------
 724
 725       when Attribute_Alignment => Alignment : declare
 726          Ptyp     : constant Entity_Id := Etype (Pref);
 727          New_Node : Node_Id;
 728
 729       begin
 730          --  For class-wide types, X'Class'Alignment is transformed into a
 731          --  direct reference to the Alignment of the class type, so that the
 732          --  back end does not have to deal with the X'Class'Alignment
 733          --  reference.
 734
 735          if Is_Entity_Name (Pref)
 736            and then Is_Class_Wide_Type (Entity (Pref))
 737          then
 738             Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
 739             return;
 740
 741          --  For x'Alignment applied to an object of a class wide type,
 742          --  transform X'Alignment into a call to the predefined primitive
 743          --  operation _Alignment applied to X.
 744
 745          elsif Is_Class_Wide_Type (Ptyp) then
 746             New_Node :=
 747               Make_Function_Call (Loc,
 748                 Name => New_Reference_To
 749                   (Find_Prim_Op (Ptyp, Name_uAlignment), Loc),
 750                 Parameter_Associations => New_List (Pref));
 751
 752             if Typ /= Standard_Integer then
 753
 754                --  The context is a specific integer type with which the
 755                --  original attribute was compatible. The function has a
 756                --  specific type as well, so to preserve the compatibility
 757                --  we must convert explicitly.
 758
 759                New_Node := Convert_To (Typ, New_Node);
 760             end if;
 761
 762             Rewrite (N, New_Node);
 763             Analyze_And_Resolve (N, Typ);
 764             return;
 765
 766          --  For all other cases, we just have to deal with the case of
 767          --  the fact that the result can be universal.
 768
 769          else
 770             Apply_Universal_Integer_Attribute_Checks (N);
 771          end if;
 772       end Alignment;
 773
 774       ---------------
 775       -- AST_Entry --
 776       ---------------
 777
 778       when Attribute_AST_Entry => AST_Entry : declare
 779          Ttyp : Entity_Id;
 780          T_Id : Node_Id;
 781          Eent : Entity_Id;
 782
 783          Entry_Ref : Node_Id;
 784          --  The reference to the entry or entry family
 785
 786          Index : Node_Id;
 787          --  The index expression for an entry family reference, or
 788          --  the Empty if Entry_Ref references a simple entry.
 789
 790       begin
 791          if Nkind (Pref) = N_Indexed_Component then
 792             Entry_Ref := Prefix (Pref);
 793             Index := First (Expressions (Pref));
 794          else
 795             Entry_Ref := Pref;
 796             Index := Empty;
 797          end if;
 798
 799          --  Get expression for Task_Id and the entry entity
 800
 801          if Nkind (Entry_Ref) = N_Selected_Component then
 802             T_Id :=
 803               Make_Attribute_Reference (Loc,
 804                 Attribute_Name => Name_Identity,
 805                 Prefix         => Prefix (Entry_Ref));
 806
 807             Ttyp := Etype (Prefix (Entry_Ref));
 808             Eent := Entity (Selector_Name (Entry_Ref));
 809
 810          else
 811             T_Id :=
 812               Make_Function_Call (Loc,
 813                 Name => New_Occurrence_Of (RTE (RE_Current_Task), Loc));
 814
 815             Eent  := Entity (Entry_Ref);
 816
 817             --  We have to find the enclosing task to get the task type
 818             --  There must be one, since we already validated this earlier
 819
 820             Ttyp := Current_Scope;
 821             while not Is_Task_Type (Ttyp) loop
 822                Ttyp := Scope (Ttyp);
 823             end loop;
 824          end if;
 825
 826          --  Now rewrite the attribute with a call to Create_AST_Handler
 827
 828          Rewrite (N,
 829            Make_Function_Call (Loc,
 830              Name => New_Occurrence_Of (RTE (RE_Create_AST_Handler), Loc),
 831              Parameter_Associations => New_List (
 832                T_Id,
 833                Entry_Index_Expression (Loc, Eent, Index, Ttyp))));
 834
 835          Analyze_And_Resolve (N, RTE (RE_AST_Handler));
 836       end AST_Entry;
 837
 838       ------------------
 839       -- Bit_Position --
 840       ------------------
 841
 842       --  We compute this if a component clause was present, otherwise
 843       --  we leave the computation up to Gigi, since we don't know what
 844       --  layout will be chosen.
 845
 846       --  Note that the attribute can apply to a naked record component
 847       --  in generated code (i.e. the prefix is an identifier that
 848       --  references the component or discriminant entity).
 849
 850       when Attribute_Bit_Position => Bit_Position :
 851       declare
 852          CE : Entity_Id;
 853
 854       begin
 855          if Nkind (Pref) = N_Identifier then
 856             CE := Entity (Pref);
 857          else
 858             CE := Entity (Selector_Name (Pref));
 859          end if;
 860
 861          if Known_Static_Component_Bit_Offset (CE) then
 862             Rewrite (N,
 863               Make_Integer_Literal (Loc,
 864                 Intval => Component_Bit_Offset (CE)));
 865             Analyze_And_Resolve (N, Typ);
 866
 867          else
 868             Apply_Universal_Integer_Attribute_Checks (N);
 869          end if;
 870       end Bit_Position;
 871
 872       ------------------
 873       -- Body_Version --
 874       ------------------
 875
 876       --  A reference to P'Body_Version or P'Version is expanded to
 877
 878       --     Vnn : Unsigned;
 879       --     pragma Import (C, Vnn, "uuuuT";
 880       --     ...
 881       --     Get_Version_String (Vnn)
 882
 883       --  where uuuu is the unit name (dots replaced by double underscore)
 884       --  and T is B for the cases of Body_Version, or Version applied to a
 885       --  subprogram acting as its own spec, and S for Version applied to a
 886       --  subprogram spec or package. This sequence of code references the
 887       --  the unsigned constant created in the main program by the binder.
 888
 889       --  A special exception occurs for Standard, where the string
 890       --  returned is a copy of the library  string in gnatvsn.ads.
 891
 892       when Attribute_Body_Version | Attribute_Version => Version : declare
 893          E    : constant Entity_Id :=
 894                   Make_Defining_Identifier (Loc, New_Internal_Name ('V'));
 895          Pent : Entity_Id := Entity (Pref);
 896          S    : String_Id;
 897
 898       begin
 899          --  If not library unit, get to containing library unit
 900
 901          while Pent /= Standard_Standard
 902            and then Scope (Pent) /= Standard_Standard
 903          loop
 904             Pent := Scope (Pent);
 905          end loop;
 906
 907          --  Special case Standard
 908
 909          if Pent = Standard_Standard
 910            or else Pent = Standard_ASCII
 911          then
 912             Name_Buffer (1 .. Verbose_Library_Version'Length) :=
 913               Verbose_Library_Version;
 914             Name_Len := Verbose_Library_Version'Length;
 915             Rewrite (N,
 916               Make_String_Literal (Loc,
 917                 Strval => String_From_Name_Buffer));
 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       begin
1741          --  If no underlying type, we have an error that will be diagnosed
1742          --  elsewhere, so here we just completely ignore the expansion.
1743
1744          if No (U_Type) then
1745             return;
1746          end if;
1747
1748          --  If there is a TSS for Input, just call it
1749
1750          Fname := Find_Stream_Subprogram (P_Type, TSS_Stream_Input);
1751
1752          if Present (Fname) then
1753             null;
1754
1755          else
1756             --  If there is a Stream_Convert pragma, use it, we rewrite
1757
1758             --     sourcetyp'Input (stream)
1759
1760             --  as
1761
1762             --     sourcetyp (streamread (strmtyp'Input (stream)));
1763
1764             --  where stmrearead is the given Read function that converts
1765             --  an argument of type strmtyp to type sourcetyp or a type
1766             --  from which it is derived. The extra conversion is required
1767             --  for the derived case.
1768
1769             Prag :=
1770               Get_Rep_Pragma
1771                 (Implementation_Base_Type (P_Type), Name_Stream_Convert);
1772
1773             if Present (Prag) then
1774                Arg2  := Next (First (Pragma_Argument_Associations (Prag)));
1775                Rfunc := Entity (Expression (Arg2));
1776
1777                Rewrite (N,
1778                  Convert_To (B_Type,
1779                    Make_Function_Call (Loc,
1780                      Name => New_Occurrence_Of (Rfunc, Loc),
1781                      Parameter_Associations => New_List (
1782                        Make_Attribute_Reference (Loc,
1783                          Prefix =>
1784                            New_Occurrence_Of
1785                              (Etype (First_Formal (Rfunc)), Loc),
1786                          Attribute_Name => Name_Input,
1787                          Expressions => Exprs)))));
1788
1789                Analyze_And_Resolve (N, B_Type);
1790                return;
1791
1792             --  Elementary types
1793
1794             elsif Is_Elementary_Type (U_Type) then
1795
1796                --  A special case arises if we have a defined _Read routine,
1797                --  since in this case we are required to call this routine.
1798
1799                if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then
1800                   Build_Record_Or_Elementary_Input_Function
1801                     (Loc, U_Type, Decl, Fname);
1802                   Insert_Action (N, Decl);
1803
1804                --  For normal cases, we call the I_xxx routine directly
1805
1806                else
1807                   Rewrite (N, Build_Elementary_Input_Call (N));
1808                   Analyze_And_Resolve (N, P_Type);
1809                   return;
1810                end if;
1811
1812             --  Array type case
1813
1814             elsif Is_Array_Type (U_Type) then
1815                Build_Array_Input_Function (Loc, U_Type, Decl, Fname);
1816                Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
1817
1818             --  Dispatching case with class-wide type
1819
1820             elsif Is_Class_Wide_Type (P_Type) then
1821
1822                declare
1823                   Rtyp : constant Entity_Id := Root_Type (P_Type);
1824                   Dnn  : Entity_Id;
1825                   Decl : Node_Id;
1826
1827                begin
1828                   --  Read the internal tag (RM 13.13.2(34)) and use it to
1829                   --  initialize a dummy tag object:
1830
1831                   --    Dnn : Ada.Tags.Tag
1832                   --             := Internal_Tag (String'Input (Strm));
1833
1834                   --  This dummy object is used only to provide a controlling
1835                   --  argument for the eventual _Input call.
1836
1837                   Dnn :=
1838                     Make_Defining_Identifier (Loc,
1839                       Chars => New_Internal_Name ('D'));
1840
1841                   Decl :=
1842                     Make_Object_Declaration (Loc,
1843                       Defining_Identifier => Dnn,
1844                       Object_Definition =>
1845                         New_Occurrence_Of (RTE (RE_Tag), Loc),
1846                       Expression =>
1847                         Make_Function_Call (Loc,
1848                           Name =>
1849                             New_Occurrence_Of (RTE (RE_Internal_Tag), Loc),
1850                           Parameter_Associations => New_List (
1851                             Make_Attribute_Reference (Loc,
1852                               Prefix =>
1853                                 New_Occurrence_Of (Standard_String, Loc),
1854                               Attribute_Name => Name_Input,
1855                               Expressions => New_List (
1856                                 Relocate_Node
1857                                   (Duplicate_Subexpr (Strm)))))));
1858
1859                   Insert_Action (N, Decl);
1860
1861                   --  Now we need to get the entity for the call, and construct
1862                   --  a function call node, where we preset a reference to Dnn
1863                   --  as the controlling argument (doing an unchecked
1864                   --  conversion to the classwide tagged type to make it
1865                   --  look like a real tagged object).
1866
1867                   Fname := Find_Prim_Op (Rtyp, TSS_Stream_Input);
1868                   Cntrl := Unchecked_Convert_To (P_Type,
1869                              New_Occurrence_Of (Dnn, Loc));
1870                   Set_Etype (Cntrl, P_Type);
1871                   Set_Parent (Cntrl, N);
1872                end;
1873
1874             --  For tagged types, use the primitive Input function
1875
1876             elsif Is_Tagged_Type (U_Type) then
1877                Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
1878
1879             --  All other record type cases, including protected records.
1880             --  The latter only arise for expander generated code for
1881             --  handling shared passive partition access.
1882
1883             else
1884                pragma Assert
1885                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
1886
1887                --  Ada 2005 (AI-216): Program_Error is raised when executing
1888                --  the default implementation of the Input attribute of an
1889                --  unchecked union type if the type lacks default discriminant
1890                --  values.
1891
1892                if Is_Unchecked_Union (Base_Type (U_Type))
1893                  and then not Present (Discriminant_Constraint (U_Type))
1894                then
1895                   Insert_Action (N,
1896                     Make_Raise_Program_Error (Loc,
1897                       Reason => PE_Unchecked_Union_Restriction));
1898
1899                   return;
1900                end if;
1901
1902                Build_Record_Or_Elementary_Input_Function
1903                  (Loc, Base_Type (U_Type), Decl, Fname);
1904                Insert_Action (N, Decl);
1905             end if;
1906          end if;
1907
1908          --  If we fall through, Fname is the function to be called. The
1909          --  result is obtained by calling the appropriate function, then
1910          --  converting the result. The conversion does a subtype check.
1911
1912          Call :=
1913            Make_Function_Call (Loc,
1914              Name => New_Occurrence_Of (Fname, Loc),
1915              Parameter_Associations => New_List (
1916                 Relocate_Node (Strm)));
1917
1918          Set_Controlling_Argument (Call, Cntrl);
1919          Rewrite (N, Unchecked_Convert_To (P_Type, Call));
1920          Analyze_And_Resolve (N, P_Type);
1921       end Input;
1922
1923       -------------------
1924       -- Integer_Value --
1925       -------------------
1926
1927       --  We transform
1928
1929       --    inttype'Fixed_Value (fixed-value)
1930
1931       --  into
1932
1933       --    inttype(integer-value))
1934
1935       --  we do all the required analysis of the conversion here, because
1936       --  we do not want this to go through the fixed-point conversion
1937       --  circuits. Note that gigi always treats fixed-point as equivalent
1938       --  to the corresponding integer type anyway.
1939
1940       when Attribute_Integer_Value => Integer_Value :
1941       begin
1942          Rewrite (N,
1943            Make_Type_Conversion (Loc,
1944              Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
1945              Expression   => Relocate_Node (First (Exprs))));
1946          Set_Etype (N, Entity (Pref));
1947          Set_Analyzed (N);
1948
1949       --  Note: it might appear that a properly analyzed unchecked conversion
1950       --  would be just fine here, but that's not the case, since the full
1951       --  range checks performed by the following call are critical!
1952
1953          Apply_Type_Conversion_Checks (N);
1954       end Integer_Value;
1955
1956       ----------
1957       -- Last --
1958       ----------
1959
1960       when Attribute_Last => declare
1961          Ptyp : constant Entity_Id := Etype (Pref);
1962
1963       begin
1964          --  If the prefix type is a constrained packed array type which
1965          --  already has a Packed_Array_Type representation defined, then
1966          --  replace this attribute with a direct reference to 'Last of the
1967          --  appropriate index subtype (since otherwise Gigi will try to give
1968          --  us the value of 'Last for this implementation type).
1969
1970          if Is_Constrained_Packed_Array (Ptyp) then
1971             Rewrite (N,
1972               Make_Attribute_Reference (Loc,
1973                 Attribute_Name => Name_Last,
1974                 Prefix => New_Reference_To (Get_Index_Subtype (N), Loc)));
1975             Analyze_And_Resolve (N, Typ);
1976
1977          elsif Is_Access_Type (Ptyp) then
1978             Apply_Access_Check (N);
1979          end if;
1980       end;
1981
1982       --------------
1983       -- Last_Bit --
1984       --------------
1985
1986       --  We compute this if a component clause was present, otherwise
1987       --  we leave the computation up to Gigi, since we don't know what
1988       --  layout will be chosen.
1989
1990       when Attribute_Last_Bit => Last_Bit :
1991       declare
1992          CE : constant Entity_Id := Entity (Selector_Name (Pref));
1993
1994       begin
1995          if Known_Static_Component_Bit_Offset (CE)
1996            and then Known_Static_Esize (CE)
1997          then
1998             Rewrite (N,
1999               Make_Integer_Literal (Loc,
2000                Intval => (Component_Bit_Offset (CE) mod System_Storage_Unit)
2001                                 + Esize (CE) - 1));
2002
2003             Analyze_And_Resolve (N, Typ);
2004
2005          else
2006             Apply_Universal_Integer_Attribute_Checks (N);
2007          end if;
2008       end Last_Bit;
2009
2010       ------------------
2011       -- Leading_Part --
2012       ------------------
2013
2014       --  Transforms 'Leading_Part into a call to the floating-point attribute
2015       --  function Leading_Part in Fat_xxx (where xxx is the root type)
2016
2017       --  Note: strictly, we should have special case code to deal with
2018       --  absurdly large positive arguments (greater than Integer'Last),
2019       --  which result in returning the first argument unchanged, but it
2020       --  hardly seems worth the effort. We raise constraint error for
2021       --  absurdly negative arguments which is fine.
2022
2023       when Attribute_Leading_Part =>
2024          Expand_Fpt_Attribute_RI (N);
2025
2026       ------------
2027       -- Length --
2028       ------------
2029
2030       when Attribute_Length => declare
2031          Ptyp : constant Entity_Id := Etype (Pref);
2032          Ityp : Entity_Id;
2033          Xnum : Uint;
2034
2035       begin
2036          --  Processing for packed array types
2037
2038          if Is_Array_Type (Ptyp) and then Is_Packed (Ptyp) then
2039             Ityp := Get_Index_Subtype (N);
2040
2041             --  If the index type, Ityp, is an enumeration type with
2042             --  holes, then we calculate X'Length explicitly using
2043
2044             --     Typ'Max
2045             --       (0, Ityp'Pos (X'Last  (N)) -
2046             --           Ityp'Pos (X'First (N)) + 1);
2047
2048             --  Since the bounds in the template are the representation
2049             --  values and gigi would get the wrong value.
2050
2051             if Is_Enumeration_Type (Ityp)
2052               and then Present (Enum_Pos_To_Rep (Base_Type (Ityp)))
2053             then
2054                if No (Exprs) then
2055                   Xnum := Uint_1;
2056                else
2057                   Xnum := Expr_Value (First (Expressions (N)));
2058                end if;
2059
2060                Rewrite (N,
2061                  Make_Attribute_Reference (Loc,
2062                    Prefix         => New_Occurrence_Of (Typ, Loc),
2063                    Attribute_Name => Name_Max,
2064                    Expressions    => New_List
2065                      (Make_Integer_Literal (Loc, 0),
2066
2067                       Make_Op_Add (Loc,
2068                         Left_Opnd =>
2069                           Make_Op_Subtract (Loc,
2070                             Left_Opnd =>
2071                               Make_Attribute_Reference (Loc,
2072                                 Prefix => New_Occurrence_Of (Ityp, Loc),
2073                                 Attribute_Name => Name_Pos,
2074
2075                                 Expressions => New_List (
2076                                   Make_Attribute_Reference (Loc,
2077                                     Prefix => Duplicate_Subexpr (Pref),
2078                                    Attribute_Name => Name_Last,
2079                                     Expressions => New_List (
2080                                       Make_Integer_Literal (Loc, Xnum))))),
2081
2082                             Right_Opnd =>
2083                               Make_Attribute_Reference (Loc,
2084                                 Prefix => New_Occurrence_Of (Ityp, Loc),
2085                                 Attribute_Name => Name_Pos,
2086
2087                                 Expressions => New_List (
2088                                   Make_Attribute_Reference (Loc,
2089                                     Prefix =>
2090                                       Duplicate_Subexpr_No_Checks (Pref),
2091                                    Attribute_Name => Name_First,
2092                                     Expressions => New_List (
2093                                       Make_Integer_Literal (Loc, Xnum)))))),
2094
2095                         Right_Opnd => Make_Integer_Literal (Loc, 1)))));
2096
2097                Analyze_And_Resolve (N, Typ, Suppress => All_Checks);
2098                return;
2099
2100             --  If the prefix type is a constrained packed array type which
2101             --  already has a Packed_Array_Type representation defined, then
2102             --  replace this attribute with a direct reference to 'Range_Length
2103             --  of the appropriate index subtype (since otherwise Gigi will try
2104             --  to give us the value of 'Length for this implementation type).
2105
2106             elsif Is_Constrained (Ptyp) then
2107                Rewrite (N,
2108                  Make_Attribute_Reference (Loc,
2109                    Attribute_Name => Name_Range_Length,
2110                    Prefix => New_Reference_To (Ityp, Loc)));
2111                Analyze_And_Resolve (N, Typ);
2112             end if;
2113
2114          --  If we have a packed array that is not bit packed, which was
2115
2116          --  Access type case
2117
2118          elsif Is_Access_Type (Ptyp) then
2119             Apply_Access_Check (N);
2120
2121             --  If the designated type is a packed array type, then we
2122             --  convert the reference to:
2123
2124             --    typ'Max (0, 1 +
2125             --                xtyp'Pos (Pref'Last (Expr)) -
2126             --                xtyp'Pos (Pref'First (Expr)));
2127
2128             --  This is a bit complex, but it is the easiest thing to do
2129             --  that works in all cases including enum types with holes
2130             --  xtyp here is the appropriate index type.
2131
2132             declare
2133                Dtyp : constant Entity_Id := Designated_Type (Ptyp);
2134                Xtyp : Entity_Id;
2135
2136             begin
2137                if Is_Array_Type (Dtyp) and then Is_Packed (Dtyp) then
2138                   Xtyp := Get_Index_Subtype (N);
2139
2140                   Rewrite (N,
2141                     Make_Attribute_Reference (Loc,
2142                       Prefix         => New_Occurrence_Of (Typ, Loc),
2143                       Attribute_Name => Name_Max,
2144                       Expressions    => New_List (
2145                         Make_Integer_Literal (Loc, 0),
2146
2147                         Make_Op_Add (Loc,
2148                           Make_Integer_Literal (Loc, 1),
2149                           Make_Op_Subtract (Loc,
2150                             Left_Opnd =>
2151                               Make_Attribute_Reference (Loc,
2152                                 Prefix => New_Occurrence_Of (Xtyp, Loc),
2153                                 Attribute_Name => Name_Pos,
2154                                 Expressions    => New_List (
2155                                   Make_Attribute_Reference (Loc,
2156                                     Prefix => Duplicate_Subexpr (Pref),
2157                                     Attribute_Name => Name_Last,
2158                                     Expressions =>
2159                                       New_Copy_List (Exprs)))),
2160
2161                             Right_Opnd =>
2162                               Make_Attribute_Reference (Loc,
2163                                 Prefix => New_Occurrence_Of (Xtyp, Loc),
2164                                 Attribute_Name => Name_Pos,
2165                                 Expressions    => New_List (
2166                                   Make_Attribute_Reference (Loc,
2167                                     Prefix =>
2168                                       Duplicate_Subexpr_No_Checks (Pref),
2169                                     Attribute_Name => Name_First,
2170                                     Expressions =>
2171                                       New_Copy_List (Exprs)))))))));
2172
2173                   Analyze_And_Resolve (N, Typ);
2174                end if;
2175             end;
2176
2177          --  Otherwise leave it to gigi
2178
2179          else
2180             Apply_Universal_Integer_Attribute_Checks (N);
2181          end if;
2182       end;
2183
2184       -------------
2185       -- Machine --
2186       -------------
2187
2188       --  Transforms 'Machine into a call to the floating-point attribute
2189       --  function Machine in Fat_xxx (where xxx is the root type)
2190
2191       when Attribute_Machine =>
2192          Expand_Fpt_Attribute_R (N);
2193
2194       ------------------
2195       -- Machine_Size --
2196       ------------------
2197
2198       --  Machine_Size is equivalent to Object_Size, so transform it into
2199       --  Object_Size and that way Gigi never sees Machine_Size.
2200
2201       when Attribute_Machine_Size =>
2202          Rewrite (N,
2203            Make_Attribute_Reference (Loc,
2204              Prefix => Prefix (N),
2205              Attribute_Name => Name_Object_Size));
2206
2207          Analyze_And_Resolve (N, Typ);
2208
2209       --------------
2210       -- Mantissa --
2211       --------------
2212
2213       --  The only case that can get this far is the dynamic case of the
2214       --  old Ada 83 Mantissa attribute for the fixed-point case. For this
2215       --  case, we expand:
2216
2217       --    typ'Mantissa
2218
2219       --  into
2220
2221       --    ityp (System.Mantissa.Mantissa_Value
2222       --           (Integer'Integer_Value (typ'First),
2223       --            Integer'Integer_Value (typ'Last)));
2224
2225       when Attribute_Mantissa => Mantissa : declare
2226          Ptyp : constant Entity_Id := Etype (Pref);
2227
2228       begin
2229          Rewrite (N,
2230            Convert_To (Typ,
2231              Make_Function_Call (Loc,
2232                Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
2233
2234                Parameter_Associations => New_List (
2235
2236                  Make_Attribute_Reference (Loc,
2237                    Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2238                    Attribute_Name => Name_Integer_Value,
2239                    Expressions => New_List (
2240
2241                      Make_Attribute_Reference (Loc,
2242                        Prefix => New_Occurrence_Of (Ptyp, Loc),
2243                        Attribute_Name => Name_First))),
2244
2245                  Make_Attribute_Reference (Loc,
2246                    Prefix => New_Occurrence_Of (Standard_Integer, Loc),
2247                    Attribute_Name => Name_Integer_Value,
2248                    Expressions => New_List (
2249
2250                      Make_Attribute_Reference (Loc,
2251                        Prefix => New_Occurrence_Of (Ptyp, Loc),
2252                        Attribute_Name => Name_Last)))))));
2253
2254          Analyze_And_Resolve (N, Typ);
2255       end Mantissa;
2256
2257       -----------
2258       -- Model --
2259       -----------
2260
2261       --  Transforms 'Model into a call to the floating-point attribute
2262       --  function Model in Fat_xxx (where xxx is the root type)
2263
2264       when Attribute_Model =>
2265          Expand_Fpt_Attribute_R (N);
2266
2267       -----------------
2268       -- Object_Size --
2269       -----------------
2270
2271       --  The processing for Object_Size shares the processing for Size
2272
2273       ------------
2274       -- Output --
2275       ------------
2276
2277       when Attribute_Output => Output : declare
2278          P_Type : constant Entity_Id := Entity (Pref);
2279          U_Type : constant Entity_Id := Underlying_Type (P_Type);
2280          Pname  : Entity_Id;
2281          Decl   : Node_Id;
2282          Prag   : Node_Id;
2283          Arg3   : Node_Id;
2284          Wfunc  : Node_Id;
2285
2286       begin
2287          --  If no underlying type, we have an error that will be diagnosed
2288          --  elsewhere, so here we just completely ignore the expansion.
2289
2290          if No (U_Type) then
2291             return;
2292          end if;
2293
2294          --  If TSS for Output is present, just call it
2295
2296          Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Output);
2297
2298          if Present (Pname) then
2299             null;
2300
2301          else
2302             --  If there is a Stream_Convert pragma, use it, we rewrite
2303
2304             --     sourcetyp'Output (stream, Item)
2305
2306             --  as
2307
2308             --     strmtyp'Output (Stream, strmwrite (acttyp (Item)));
2309
2310             --  where strmwrite is the given Write function that converts
2311             --  an argument of type sourcetyp or a type acctyp, from which
2312             --  it is derived to type strmtyp. The conversion to acttyp is
2313             --  required for the derived case.
2314
2315             Prag :=
2316               Get_Rep_Pragma
2317                 (Implementation_Base_Type (P_Type), Name_Stream_Convert);
2318
2319             if Present (Prag) then
2320                Arg3 :=
2321                  Next (Next (First (Pragma_Argument_Associations (Prag))));
2322                Wfunc := Entity (Expression (Arg3));
2323
2324                Rewrite (N,
2325                  Make_Attribute_Reference (Loc,
2326                    Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
2327                    Attribute_Name => Name_Output,
2328                    Expressions => New_List (
2329                    Relocate_Node (First (Exprs)),
2330                      Make_Function_Call (Loc,
2331                        Name => New_Occurrence_Of (Wfunc, Loc),
2332                        Parameter_Associations => New_List (
2333                          Convert_To (Etype (First_Formal (Wfunc)),
2334                            Relocate_Node (Next (First (Exprs)))))))));
2335
2336                Analyze (N);
2337                return;
2338
2339             --  For elementary types, we call the W_xxx routine directly.
2340             --  Note that the effect of Write and Output is identical for
2341             --  the case of an elementary type, since there are no
2342             --  discriminants or bounds.
2343
2344             elsif Is_Elementary_Type (U_Type) then
2345
2346                --  A special case arises if we have a defined _Write routine,
2347                --  since in this case we are required to call this routine.
2348
2349                if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then
2350                   Build_Record_Or_Elementary_Output_Procedure
2351                     (Loc, U_Type, Decl, Pname);
2352                   Insert_Action (N, Decl);
2353
2354                --  For normal cases, we call the W_xxx routine directly
2355
2356                else
2357                   Rewrite (N, Build_Elementary_Write_Call (N));
2358                   Analyze (N);
2359                   return;
2360                end if;
2361
2362             --  Array type case
2363
2364             elsif Is_Array_Type (U_Type) then
2365                Build_Array_Output_Procedure (Loc, U_Type, Decl, Pname);
2366                Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
2367
2368             --  Class-wide case, first output external tag, then dispatch
2369             --  to the appropriate primitive Output function (RM 13.13.2(31)).
2370
2371             elsif Is_Class_Wide_Type (P_Type) then
2372                Tag_Write : declare
2373                   Strm : constant Node_Id := First (Exprs);
2374                   Item : constant Node_Id := Next (Strm);
2375
2376                begin
2377                   --  The code is:
2378                   --  String'Output (Strm, External_Tag (Item'Tag))
2379
2380                   Insert_Action (N,
2381                     Make_Attribute_Reference (Loc,
2382                       Prefix => New_Occurrence_Of (Standard_String, Loc),
2383                       Attribute_Name => Name_Output,
2384                       Expressions => New_List (
2385                         Relocate_Node (Duplicate_Subexpr (Strm)),
2386                         Make_Function_Call (Loc,
2387                           Name =>
2388                             New_Occurrence_Of (RTE (RE_External_Tag), Loc),
2389                           Parameter_Associations => New_List (
2390                            Make_Attribute_Reference (Loc,
2391                              Prefix =>
2392                                Relocate_Node
2393                                  (Duplicate_Subexpr (Item, Name_Req => True)),
2394                              Attribute_Name => Name_Tag))))));
2395                end Tag_Write;
2396
2397                Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
2398
2399             --  Tagged type case, use the primitive Output function
2400
2401             elsif Is_Tagged_Type (U_Type) then
2402                Pname := Find_Prim_Op (U_Type, TSS_Stream_Output);
2403
2404             --  All other record type cases, including protected records.
2405             --  The latter only arise for expander generated code for
2406             --  handling shared passive partition access.
2407
2408             else
2409                pragma Assert
2410                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
2411
2412                --  Ada 2005 (AI-216): Program_Error is raised when executing
2413                --  the default implementation of the Output attribute of an
2414                --  unchecked union type if the type lacks default discriminant
2415                --  values.
2416
2417                if Is_Unchecked_Union (Base_Type (U_Type))
2418                  and then not Present (Discriminant_Constraint (U_Type))
2419                then
2420                   Insert_Action (N,
2421                     Make_Raise_Program_Error (Loc,
2422                       Reason => PE_Unchecked_Union_Restriction));
2423
2424                   return;
2425                end if;
2426
2427                Build_Record_Or_Elementary_Output_Procedure
2428                  (Loc, Base_Type (U_Type), Decl, Pname);
2429                Insert_Action (N, Decl);
2430             end if;
2431          end if;
2432
2433          --  If we fall through, Pname is the name of the procedure to call
2434
2435          Rewrite_Stream_Proc_Call (Pname);
2436       end Output;
2437
2438       ---------
2439       -- Pos --
2440       ---------
2441
2442       --  For enumeration types with a standard representation, Pos is
2443       --  handled by Gigi.
2444
2445       --  For enumeration types, with a non-standard representation we
2446       --  generate a call to the _Rep_To_Pos function created when the
2447       --  type was frozen. The call has the form
2448
2449       --    _rep_to_pos (expr, flag)
2450
2451       --  The parameter flag is True if range checks are enabled, causing
2452       --  Program_Error to be raised if the expression has an invalid
2453       --  representation, and False if range checks are suppressed.
2454
2455       --  For integer types, Pos is equivalent to a simple integer
2456       --  conversion and we rewrite it as such
2457
2458       when Attribute_Pos => Pos :
2459       declare
2460          Etyp : Entity_Id := Base_Type (Entity (Pref));
2461
2462       begin
2463          --  Deal with zero/non-zero boolean values
2464
2465          if Is_Boolean_Type (Etyp) then
2466             Adjust_Condition (First (Exprs));
2467             Etyp := Standard_Boolean;
2468             Set_Prefix (N, New_Occurrence_Of (Standard_Boolean, Loc));
2469          end if;
2470
2471          --  Case of enumeration type
2472
2473          if Is_Enumeration_Type (Etyp) then
2474
2475             --  Non-standard enumeration type (generate call)
2476
2477             if Present (Enum_Pos_To_Rep (Etyp)) then
2478                Append_To (Exprs, Rep_To_Pos_Flag (Etyp, Loc));
2479                Rewrite (N,
2480                  Convert_To (Typ,
2481                    Make_Function_Call (Loc,
2482                      Name =>
2483                        New_Reference_To (TSS (Etyp, TSS_Rep_To_Pos), Loc),
2484                      Parameter_Associations => Exprs)));
2485
2486                Analyze_And_Resolve (N, Typ);
2487
2488             --  Standard enumeration type (do universal integer check)
2489
2490             else
2491                Apply_Universal_Integer_Attribute_Checks (N);
2492             end if;
2493
2494          --  Deal with integer types (replace by conversion)
2495
2496          elsif Is_Integer_Type (Etyp) then
2497             Rewrite (N, Convert_To (Typ, First (Exprs)));
2498             Analyze_And_Resolve (N, Typ);
2499          end if;
2500
2501       end Pos;
2502
2503       --------------
2504       -- Position --
2505       --------------
2506
2507       --  We compute this if a component clause was present, otherwise
2508       --  we leave the computation up to Gigi, since we don't know what
2509       --  layout will be chosen.
2510
2511       when Attribute_Position => Position :
2512       declare
2513          CE : constant Entity_Id := Entity (Selector_Name (Pref));
2514
2515       begin
2516          if Present (Component_Clause (CE)) then
2517             Rewrite (N,
2518               Make_Integer_Literal (Loc,
2519                 Intval => Component_Bit_Offset (CE) / System_Storage_Unit));
2520             Analyze_And_Resolve (N, Typ);
2521
2522          else
2523             Apply_Universal_Integer_Attribute_Checks (N);
2524          end if;
2525       end Position;
2526
2527       ----------
2528       -- Pred --
2529       ----------
2530
2531       --  1. Deal with enumeration types with holes
2532       --  2. For floating-point, generate call to attribute function
2533       --  3. For other cases, deal with constraint checking
2534
2535       when Attribute_Pred => Pred :
2536       declare
2537          Ptyp : constant Entity_Id := Base_Type (Etype (Pref));
2538
2539       begin
2540          --  For enumeration types with non-standard representations, we
2541          --  expand typ'Pred (x) into
2542
2543          --    Pos_To_Rep (Rep_To_Pos (x) - 1)
2544
2545          --    If the representation is contiguous, we compute instead
2546          --    Lit1 + Rep_to_Pos (x -1), to catch invalid representations.
2547
2548          if Is_Enumeration_Type (Ptyp)
2549            and then Present (Enum_Pos_To_Rep (Ptyp))
2550          then
2551             if Has_Contiguous_Rep (Ptyp) then
2552                Rewrite (N,
2553                   Unchecked_Convert_To (Ptyp,
2554                      Make_Op_Add (Loc,
2555                         Left_Opnd  =>
2556                          Make_Integer_Literal (Loc,
2557                            Enumeration_Rep (First_Literal (Ptyp))),
2558                         Right_Opnd =>
2559                           Make_Function_Call (Loc,
2560                             Name =>
2561                               New_Reference_To
2562                                (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
2563
2564                             Parameter_Associations =>
2565                               New_List (
2566                                 Unchecked_Convert_To (Ptyp,
2567                                   Make_Op_Subtract (Loc,
2568                                     Left_Opnd =>
2569                                      Unchecked_Convert_To (Standard_Integer,
2570                                        Relocate_Node (First (Exprs))),
2571                                     Right_Opnd =>
2572                                       Make_Integer_Literal (Loc, 1))),
2573                                 Rep_To_Pos_Flag (Ptyp, Loc))))));
2574
2575             else
2576                --  Add Boolean parameter True, to request program errror if
2577                --  we have a bad representation on our hands. If checks are
2578                --  suppressed, then add False instead
2579
2580                Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
2581                Rewrite (N,
2582                  Make_Indexed_Component (Loc,
2583                    Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
2584                    Expressions => New_List (
2585                      Make_Op_Subtract (Loc,
2586                     Left_Opnd =>
2587                       Make_Function_Call (Loc,
2588                         Name =>
2589                           New_Reference_To (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
2590                           Parameter_Associations => Exprs),
2591                     Right_Opnd => Make_Integer_Literal (Loc, 1)))));
2592             end if;
2593
2594             Analyze_And_Resolve (N, Typ);
2595
2596          --  For floating-point, we transform 'Pred into a call to the Pred
2597          --  floating-point attribute function in Fat_xxx (xxx is root type)
2598
2599          elsif Is_Floating_Point_Type (Ptyp) then
2600             Expand_Fpt_Attribute_R (N);
2601             Analyze_And_Resolve (N, Typ);
2602
2603          --  For modular types, nothing to do (no overflow, since wraps)
2604
2605          elsif Is_Modular_Integer_Type (Ptyp) then
2606             null;
2607
2608          --  For other types, if range checking is enabled, we must generate
2609          --  a check if overflow checking is enabled.
2610
2611          elsif not Overflow_Checks_Suppressed (Ptyp) then
2612             Expand_Pred_Succ (N);
2613          end if;
2614
2615       end Pred;
2616
2617       ------------------
2618       -- Range_Length --
2619       ------------------
2620
2621       when Attribute_Range_Length => Range_Length : declare
2622          P_Type : constant Entity_Id := Etype (Pref);
2623
2624       begin
2625          --  The only special processing required is for the case where
2626          --  Range_Length is applied to an enumeration type with holes.
2627          --  In this case we transform
2628
2629          --     X'Range_Length
2630
2631          --  to
2632
2633          --     X'Pos (X'Last) - X'Pos (X'First) + 1
2634
2635          --  So that the result reflects the proper Pos values instead
2636          --  of the underlying representations.
2637
2638          if Is_Enumeration_Type (P_Type)
2639            and then Has_Non_Standard_Rep (P_Type)
2640          then
2641             Rewrite (N,
2642               Make_Op_Add (Loc,
2643                 Left_Opnd =>
2644                   Make_Op_Subtract (Loc,
2645                     Left_Opnd =>
2646                       Make_Attribute_Reference (Loc,
2647                         Attribute_Name => Name_Pos,
2648                         Prefix => New_Occurrence_Of (P_Type, Loc),
2649                         Expressions => New_List (
2650                           Make_Attribute_Reference (Loc,
2651                             Attribute_Name => Name_Last,
2652                             Prefix => New_Occurrence_Of (P_Type, Loc)))),
2653
2654                     Right_Opnd =>
2655                       Make_Attribute_Reference (Loc,
2656                         Attribute_Name => Name_Pos,
2657                         Prefix => New_Occurrence_Of (P_Type, Loc),
2658                         Expressions => New_List (
2659                           Make_Attribute_Reference (Loc,
2660                             Attribute_Name => Name_First,
2661                             Prefix => New_Occurrence_Of (P_Type, Loc))))),
2662
2663                 Right_Opnd =>
2664                   Make_Integer_Literal (Loc, 1)));
2665
2666             Analyze_And_Resolve (N, Typ);
2667
2668          --  For all other cases, attribute is handled by Gigi, but we need
2669          --  to deal with the case of the range check on a universal integer.
2670
2671          else
2672             Apply_Universal_Integer_Attribute_Checks (N);
2673          end if;
2674
2675       end Range_Length;
2676
2677       ----------
2678       -- Read --
2679       ----------
2680
2681       when Attribute_Read => Read : declare
2682          P_Type : constant Entity_Id := Entity (Pref);
2683          B_Type : constant Entity_Id := Base_Type (P_Type);
2684          U_Type : constant Entity_Id := Underlying_Type (P_Type);
2685          Pname  : Entity_Id;
2686          Decl   : Node_Id;
2687          Prag   : Node_Id;
2688          Arg2   : Node_Id;
2689          Rfunc  : Node_Id;
2690          Lhs    : Node_Id;
2691          Rhs    : Node_Id;
2692
2693       begin
2694          --  If no underlying type, we have an error that will be diagnosed
2695          --  elsewhere, so here we just completely ignore the expansion.
2696
2697          if No (U_Type) then
2698             return;
2699          end if;
2700
2701          --  The simple case, if there is a TSS for Read, just call it
2702
2703          Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Read);
2704
2705          if Present (Pname) then
2706             null;
2707
2708          else
2709             --  If there is a Stream_Convert pragma, use it, we rewrite
2710
2711             --     sourcetyp'Read (stream, Item)
2712
2713             --  as
2714
2715             --     Item := sourcetyp (strmread (strmtyp'Input (Stream)));
2716
2717             --  where strmread is the given Read function that converts
2718             --  an argument of type strmtyp to type sourcetyp or a type
2719             --  from which it is derived. The conversion to sourcetyp
2720             --  is required in the latter case.
2721
2722             --  A special case arises if Item is a type conversion in which
2723             --  case, we have to expand to:
2724
2725             --     Itemx := typex (strmread (strmtyp'Input (Stream)));
2726
2727             --  where Itemx is the expression of the type conversion (i.e.
2728             --  the actual object), and typex is the type of Itemx.
2729
2730             Prag :=
2731               Get_Rep_Pragma
2732                 (Implementation_Base_Type (P_Type), Name_Stream_Convert);
2733
2734             if Present (Prag) then
2735                Arg2  := Next (First (Pragma_Argument_Associations (Prag)));
2736                Rfunc := Entity (Expression (Arg2));
2737                Lhs := Relocate_Node (Next (First (Exprs)));
2738                Rhs :=
2739                  Convert_To (B_Type,
2740                    Make_Function_Call (Loc,
2741                      Name => New_Occurrence_Of (Rfunc, Loc),
2742                      Parameter_Associations => New_List (
2743                        Make_Attribute_Reference (Loc,
2744                          Prefix =>
2745                            New_Occurrence_Of
2746                              (Etype (First_Formal (Rfunc)), Loc),
2747                          Attribute_Name => Name_Input,
2748                          Expressions => New_List (
2749                            Relocate_Node (First (Exprs)))))));
2750
2751                if Nkind (Lhs) = N_Type_Conversion then
2752                   Lhs := Expression (Lhs);
2753                   Rhs := Convert_To (Etype (Lhs), Rhs);
2754                end if;
2755
2756                Rewrite (N,
2757                  Make_Assignment_Statement (Loc,
2758                    Name       => Lhs,
2759                    Expression => Rhs));
2760                Set_Assignment_OK (Lhs);
2761                Analyze (N);
2762                return;
2763
2764             --  For elementary types, we call the I_xxx routine using the first
2765             --  parameter and then assign the result into the second parameter.
2766             --  We set Assignment_OK to deal with the conversion case.
2767
2768             elsif Is_Elementary_Type (U_Type) then
2769                declare
2770                   Lhs : Node_Id;
2771                   Rhs : Node_Id;
2772
2773                begin
2774                   Lhs := Relocate_Node (Next (First (Exprs)));
2775                   Rhs := Build_Elementary_Input_Call (N);
2776
2777                   if Nkind (Lhs) = N_Type_Conversion then
2778                      Lhs := Expression (Lhs);
2779                      Rhs := Convert_To (Etype (Lhs), Rhs);
2780                   end if;
2781
2782                   Set_Assignment_OK (Lhs);
2783
2784                   Rewrite (N,
2785                     Make_Assignment_Statement (Loc,
2786                       Name => Lhs,
2787                       Expression => Rhs));
2788
2789                   Analyze (N);
2790                   return;
2791                end;
2792
2793             --  Array type case
2794
2795             elsif Is_Array_Type (U_Type) then
2796                Build_Array_Read_Procedure (N, U_Type, Decl, Pname);
2797                Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
2798
2799             --  Tagged type case, use the primitive Read function. Note that
2800             --  this will dispatch in the class-wide case which is what we want
2801
2802             elsif Is_Tagged_Type (U_Type) then
2803                Pname := Find_Prim_Op (U_Type, TSS_Stream_Read);
2804
2805             --  All other record type cases, including protected records.
2806             --  The latter only arise for expander generated code for
2807             --  handling shared passive partition access.
2808
2809             else
2810                pragma Assert
2811                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
2812
2813                --  Ada 2005 (AI-216): Program_Error is raised when executing
2814                --  the default implementation of the Read attribute of an
2815                --  Unchecked_Union type.
2816
2817                if Is_Unchecked_Union (Base_Type (U_Type)) then
2818                   Insert_Action (N,
2819                     Make_Raise_Program_Error (Loc,
2820                       Reason => PE_Unchecked_Union_Restriction));
2821                end if;
2822
2823                if Has_Discriminants (U_Type)
2824                  and then Present
2825                    (Discriminant_Default_Value (First_Discriminant (U_Type)))
2826                then
2827                   Build_Mutable_Record_Read_Procedure
2828                     (Loc, Base_Type (U_Type), Decl, Pname);
2829                else
2830                   Build_Record_Read_Procedure
2831                     (Loc, Base_Type (U_Type), Decl, Pname);
2832                end if;
2833
2834                --  Suppress checks, uninitialized or otherwise invalid
2835                --  data does not cause constraint errors to be raised for
2836                --  a complete record read.
2837
2838                Insert_Action (N, Decl, All_Checks);
2839             end if;
2840          end if;
2841
2842          Rewrite_Stream_Proc_Call (Pname);
2843       end Read;
2844
2845       ---------------
2846       -- Remainder --
2847       ---------------
2848
2849       --  Transforms 'Remainder into a call to the floating-point attribute
2850       --  function Remainder in Fat_xxx (where xxx is the root type)
2851
2852       when Attribute_Remainder =>
2853          Expand_Fpt_Attribute_RR (N);
2854
2855       -----------
2856       -- Round --
2857       -----------
2858
2859       --  The handling of the Round attribute is quite delicate. The
2860       --  processing in Sem_Attr introduced a conversion to universal
2861       --  real, reflecting the semantics of Round, but we do not want
2862       --  anything to do with universal real at runtime, since this
2863       --  corresponds to using floating-point arithmetic.
2864
2865       --  What we have now is that the Etype of the Round attribute
2866       --  correctly indicates the final result type. The operand of
2867       --  the Round is the conversion to universal real, described
2868       --  above, and the operand of this conversion is the actual
2869       --  operand of Round, which may be the special case of a fixed
2870       --  point multiplication or division (Etype = universal fixed)
2871
2872       --  The exapander will expand first the operand of the conversion,
2873       --  then the conversion, and finally the round attribute itself,
2874       --  since we always work inside out. But we cannot simply process
2875       --  naively in this order. In the semantic world where universal
2876       --  fixed and real really exist and have infinite precision, there
2877       --  is no problem, but in the implementation world, where universal
2878       --  real is a floating-point type, we would get the wrong result.
2879
2880       --  So the approach is as follows. First, when expanding a multiply
2881       --  or divide whose type is universal fixed, we do nothing at all,
2882       --  instead deferring the operation till later.
2883
2884       --  The actual processing is done in Expand_N_Type_Conversion which
2885       --  handles the special case of Round by looking at its parent to
2886       --  see if it is a Round attribute, and if it is, handling the
2887       --  conversion (or its fixed multiply/divide child) in an appropriate
2888       --  manner.
2889
2890       --  This means that by the time we get to expanding the Round attribute
2891       --  itself, the Round is nothing more than a type conversion (and will
2892       --  often be a null type conversion), so we just replace it with the
2893       --  appropriate conversion operation.
2894
2895       when Attribute_Round =>
2896          Rewrite (N,
2897            Convert_To (Etype (N), Relocate_Node (First (Exprs))));
2898          Analyze_And_Resolve (N);
2899
2900       --------------
2901       -- Rounding --
2902       --------------
2903
2904       --  Transforms 'Rounding into a call to the floating-point attribute
2905       --  function Rounding in Fat_xxx (where xxx is the root type)
2906
2907       when Attribute_Rounding =>
2908          Expand_Fpt_Attribute_R (N);
2909
2910       -------------
2911       -- Scaling --
2912       -------------
2913
2914       --  Transforms 'Scaling into a call to the floating-point attribute
2915       --  function Scaling in Fat_xxx (where xxx is the root type)
2916
2917       when Attribute_Scaling =>
2918          Expand_Fpt_Attribute_RI (N);
2919
2920       ----------
2921       -- Size --
2922       ----------
2923
2924       when Attribute_Size        |
2925            Attribute_Object_Size |
2926            Attribute_Value_Size  |
2927            Attribute_VADS_Size   => Size :
2928
2929       declare
2930          Ptyp     : constant Entity_Id := Etype (Pref);
2931          Siz      : Uint;
2932          New_Node : Node_Id;
2933
2934       begin
2935          --  Processing for VADS_Size case. Note that this processing removes
2936          --  all traces of VADS_Size from the tree, and completes all required
2937          --  processing for VADS_Size by translating the attribute reference
2938          --  to an appropriate Size or Object_Size reference.
2939
2940          if Id = Attribute_VADS_Size
2941            or else (Use_VADS_Size and then Id = Attribute_Size)
2942          then
2943             --  If the size is specified, then we simply use the specified
2944             --  size. This applies to both types and objects. The size of an
2945             --  object can be specified in the following ways:
2946
2947             --    An explicit size object is given for an object
2948             --    A component size is specified for an indexed component
2949             --    A component clause is specified for a selected component
2950             --    The object is a component of a packed composite object
2951
2952             --  If the size is specified, then VADS_Size of an object
2953
2954             if (Is_Entity_Name (Pref)
2955                  and then Present (Size_Clause (Entity (Pref))))
2956               or else
2957                 (Nkind (Pref) = N_Component_Clause
2958                   and then (Present (Component_Clause
2959                                      (Entity (Selector_Name (Pref))))
2960                              or else Is_Packed (Etype (Prefix (Pref)))))
2961               or else
2962                 (Nkind (Pref) = N_Indexed_Component
2963                   and then (Component_Size (Etype (Prefix (Pref))) /= 0
2964                              or else Is_Packed (Etype (Prefix (Pref)))))
2965             then
2966                Set_Attribute_Name (N, Name_Size);
2967
2968             --  Otherwise if we have an object rather than a type, then the
2969             --  VADS_Size attribute applies to the type of the object, rather
2970             --  than the object itself. This is one of the respects in which
2971             --  VADS_Size differs from Size.
2972
2973             else
2974                if (not Is_Entity_Name (Pref)
2975                     or else not Is_Type (Entity (Pref)))
2976                  and then (Is_Scalar_Type (Etype (Pref))
2977                             or else Is_Constrained (Etype (Pref)))
2978                then
2979                   Rewrite (Pref, New_Occurrence_Of (Etype (Pref), Loc));
2980                end if;
2981
2982                --  For a scalar type for which no size was
2983                --  explicitly given, VADS_Size means Object_Size. This is the
2984                --  other respect in which VADS_Size differs from Size.
2985
2986                if Is_Scalar_Type (Etype (Pref))
2987                  and then No (Size_Clause (Etype (Pref)))
2988                then
2989                   Set_Attribute_Name (N, Name_Object_Size);
2990
2991                --  In all other cases, Size and VADS_Size are the sane
2992
2993                else
2994                   Set_Attribute_Name (N, Name_Size);
2995                end if;
2996             end if;
2997          end if;
2998
2999          --  For class-wide types,  X'Class'Size is transformed into a
3000          --  direct reference to the Size of the class type, so that gigi
3001          --  does not have to deal with the X'Class'Size reference.
3002
3003          if Is_Entity_Name (Pref)
3004            and then Is_Class_Wide_Type (Entity (Pref))
3005          then
3006             Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
3007             return;
3008
3009          --  For x'Size applied to an object of a class wide type, transform
3010          --  X'Size into a call to the primitive operation _Size applied to X.
3011
3012          elsif Is_Class_Wide_Type (Ptyp) then
3013             New_Node :=
3014               Make_Function_Call (Loc,
3015                 Name => New_Reference_To
3016                   (Find_Prim_Op (Ptyp, Name_uSize), Loc),
3017                 Parameter_Associations => New_List (Pref));
3018
3019             if Typ /= Standard_Long_Long_Integer then
3020
3021                --  The context is a specific integer type with which the
3022                --  original attribute was compatible. The function has a
3023                --  specific type as well, so to preserve the compatibility
3024                --  we must convert explicitly.
3025
3026                New_Node := Convert_To (Typ, New_Node);
3027             end if;
3028
3029             Rewrite (N, New_Node);
3030             Analyze_And_Resolve (N, Typ);
3031             return;
3032
3033          --  For an array component, we can do Size in the front end
3034          --  if the component_size of the array is set.
3035
3036          elsif Nkind (Pref) = N_Indexed_Component then
3037             Siz := Component_Size (Etype (Prefix (Pref)));
3038
3039          --  For a record component, we can do Size in the front end
3040          --  if there is a component clause, or if the record is packed
3041          --  and the component's size is known at compile time.
3042
3043          elsif Nkind (Pref) = N_Selected_Component then
3044             declare
3045                Rec  : constant Entity_Id := Etype (Prefix (Pref));
3046                Comp : constant Entity_Id := Entity (Selector_Name (Pref));
3047
3048             begin
3049                if Present (Component_Clause (Comp)) then
3050                   Siz := Esize (Comp);
3051
3052                elsif Is_Packed (Rec) then
3053                   Siz := RM_Size (Ptyp);
3054
3055                else
3056                   Apply_Universal_Integer_Attribute_Checks (N);
3057                   return;
3058                end if;
3059             end;
3060
3061          --  All other cases are handled by Gigi
3062
3063          else
3064             Apply_Universal_Integer_Attribute_Checks (N);
3065
3066             --  If we have Size applied to a formal parameter, that is a
3067             --  packed array subtype, then apply size to the actual subtype.
3068
3069             if Is_Entity_Name (Pref)
3070               and then Is_Formal (Entity (Pref))
3071               and then Is_Array_Type (Etype (Pref))
3072               and then Is_Packed (Etype (Pref))
3073             then
3074                Rewrite (N,
3075                  Make_Attribute_Reference (Loc,
3076                    Prefix =>
3077                      New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
3078                    Attribute_Name => Name_Size));
3079                Analyze_And_Resolve (N, Typ);
3080             end if;
3081
3082             return;
3083          end if;
3084
3085          --  Common processing for record and array component case
3086
3087          if Siz /= 0 then
3088             Rewrite (N,
3089               Make_Integer_Literal (Loc, Siz));
3090
3091             Analyze_And_Resolve (N, Typ);
3092
3093             --  The result is not a static expression
3094
3095             Set_Is_Static_Expression (N, False);
3096          end if;
3097       end Size;
3098
3099       ------------------
3100       -- Storage_Pool --
3101       ------------------
3102
3103       when Attribute_Storage_Pool =>
3104          Rewrite (N,
3105            Make_Type_Conversion (Loc,
3106              Subtype_Mark => New_Reference_To (Etype (N), Loc),
3107              Expression   => New_Reference_To (Entity (N), Loc)));
3108          Analyze_And_Resolve (N, Typ);
3109
3110       ------------------
3111       -- Storage_Size --
3112       ------------------
3113
3114       when Attribute_Storage_Size => Storage_Size :
3115       declare
3116          Ptyp : constant Entity_Id := Etype (Pref);
3117
3118       begin
3119          --  Access type case, always go to the root type
3120
3121          --  The case of access types results in a value of zero for the case
3122          --  where no storage size attribute clause has been given. If a
3123          --  storage size has been given, then the attribute is converted
3124          --  to a reference to the variable used to hold this value.
3125
3126          if Is_Access_Type (Ptyp) then
3127             if Present (Storage_Size_Variable (Root_Type (Ptyp))) then
3128                Rewrite (N,
3129                  Make_Attribute_Reference (Loc,
3130                    Prefix => New_Reference_To (Typ, Loc),
3131                    Attribute_Name => Name_Max,
3132                    Expressions => New_List (
3133                      Make_Integer_Literal (Loc, 0),
3134                      Convert_To (Typ,
3135                        New_Reference_To
3136                          (Storage_Size_Variable (Root_Type (Ptyp)), Loc)))));
3137
3138             elsif Present (Associated_Storage_Pool (Root_Type (Ptyp))) then
3139                Rewrite (N,
3140                  OK_Convert_To (Typ,
3141                    Make_Function_Call (Loc,
3142                      Name =>
3143                        New_Reference_To
3144                         (Find_Prim_Op
3145                           (Etype (Associated_Storage_Pool (Root_Type (Ptyp))),
3146                            Attribute_Name (N)),
3147                          Loc),
3148
3149                      Parameter_Associations => New_List (New_Reference_To (
3150                        Associated_Storage_Pool (Root_Type (Ptyp)), Loc)))));
3151             else
3152                Rewrite (N, Make_Integer_Literal (Loc, 0));
3153             end if;
3154
3155             Analyze_And_Resolve (N, Typ);
3156
3157          --  The case of a task type (an obsolescent feature) is handled the
3158          --  same way, seems as reasonable as anything, and it is what the
3159          --  ACVC tests (e.g. CD1009K) seem to expect.
3160
3161          --  If there is no Storage_Size variable, then we return the default
3162          --  task stack size, otherwise, expand a Storage_Size attribute as
3163          --  follows:
3164
3165          --  Typ (Adjust_Storage_Size (taskZ))
3166
3167          --  except for the case of a task object which has a Storage_Size
3168          --  pragma:
3169
3170          --  Typ (Adjust_Storage_Size (taskV!(name)._Size))
3171
3172          else
3173             if not Present (Storage_Size_Variable (Ptyp)) then
3174                Rewrite (N,
3175                  Convert_To (Typ,
3176                    Make_Function_Call (Loc,
3177                      Name =>
3178                        New_Occurrence_Of (RTE (RE_Default_Stack_Size), Loc))));
3179
3180             else
3181                if not (Is_Entity_Name (Pref) and then
3182                  Is_Task_Type (Entity (Pref))) and then
3183                    Chars (Last_Entity (Corresponding_Record_Type (Ptyp))) =
3184                      Name_uSize
3185                then
3186                   Rewrite (N,
3187                     Convert_To (Typ,
3188                       Make_Function_Call (Loc,
3189                         Name => New_Occurrence_Of (
3190                           RTE (RE_Adjust_Storage_Size), Loc),
3191                         Parameter_Associations =>
3192                           New_List (
3193                             Make_Selected_Component (Loc,
3194                               Prefix =>
3195                                 Unchecked_Convert_To (
3196                                   Corresponding_Record_Type (Ptyp),
3197                                   New_Copy_Tree (Pref)),
3198                               Selector_Name =>
3199                                 Make_Identifier (Loc, Name_uSize))))));
3200
3201                --  Task not having Storage_Size pragma
3202
3203                else
3204                   Rewrite (N,
3205                     Convert_To (Typ,
3206                       Make_Function_Call (Loc,
3207                         Name => New_Occurrence_Of (
3208                           RTE (RE_Adjust_Storage_Size), Loc),
3209                         Parameter_Associations =>
3210                           New_List (
3211                             New_Reference_To (
3212                               Storage_Size_Variable (Ptyp), Loc)))));
3213                end if;
3214
3215                Analyze_And_Resolve (N, Typ);
3216             end if;
3217          end if;
3218       end Storage_Size;
3219
3220       ----------
3221       -- Succ --
3222       ----------
3223
3224       --  1. Deal with enumeration types with holes
3225       --  2. For floating-point, generate call to attribute function
3226       --  3. For other cases, deal with constraint checking
3227
3228       when Attribute_Succ => Succ :
3229       declare
3230          Ptyp : constant Entity_Id := Base_Type (Etype (Pref));
3231
3232       begin
3233          --  For enumeration types with non-standard representations, we
3234          --  expand typ'Succ (x) into
3235
3236          --    Pos_To_Rep (Rep_To_Pos (x) + 1)
3237
3238          --    If the representation is contiguous, we compute instead
3239          --    Lit1 + Rep_to_Pos (x+1), to catch invalid representations.
3240
3241          if Is_Enumeration_Type (Ptyp)
3242            and then Present (Enum_Pos_To_Rep (Ptyp))
3243          then
3244             if Has_Contiguous_Rep (Ptyp) then
3245                Rewrite (N,
3246                   Unchecked_Convert_To (Ptyp,
3247                      Make_Op_Add (Loc,
3248                         Left_Opnd  =>
3249                          Make_Integer_Literal (Loc,
3250                            Enumeration_Rep (First_Literal (Ptyp))),
3251                         Right_Opnd =>
3252                           Make_Function_Call (Loc,
3253                             Name =>
3254                               New_Reference_To
3255                                (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
3256
3257                             Parameter_Associations =>
3258                               New_List (
3259                                 Unchecked_Convert_To (Ptyp,
3260                                   Make_Op_Add (Loc,
3261                                   Left_Opnd =>
3262                                     Unchecked_Convert_To (Standard_Integer,
3263                                       Relocate_Node (First (Exprs))),
3264                                   Right_Opnd =>
3265                                     Make_Integer_Literal (Loc, 1))),
3266                                 Rep_To_Pos_Flag (Ptyp, Loc))))));
3267             else
3268                --  Add Boolean parameter True, to request program errror if
3269                --  we have a bad representation on our hands. Add False if
3270                --  checks are suppressed.
3271
3272                Append_To (Exprs, Rep_To_Pos_Flag (Ptyp, Loc));
3273                Rewrite (N,
3274                  Make_Indexed_Component (Loc,
3275                    Prefix => New_Reference_To (Enum_Pos_To_Rep (Ptyp), Loc),
3276                    Expressions => New_List (
3277                      Make_Op_Add (Loc,
3278                        Left_Opnd =>
3279                          Make_Function_Call (Loc,
3280                            Name =>
3281                              New_Reference_To
3282                                (TSS (Ptyp, TSS_Rep_To_Pos), Loc),
3283                            Parameter_Associations => Exprs),
3284                        Right_Opnd => Make_Integer_Literal (Loc, 1)))));
3285             end if;
3286
3287             Analyze_And_Resolve (N, Typ);
3288
3289          --  For floating-point, we transform 'Succ into a call to the Succ
3290          --  floating-point attribute function in Fat_xxx (xxx is root type)
3291
3292          elsif Is_Floating_Point_Type (Ptyp) then
3293             Expand_Fpt_Attribute_R (N);
3294             Analyze_And_Resolve (N, Typ);
3295
3296          --  For modular types, nothing to do (no overflow, since wraps)
3297
3298          elsif Is_Modular_Integer_Type (Ptyp) then
3299             null;
3300
3301          --  For other types, if range checking is enabled, we must generate
3302          --  a check if overflow checking is enabled.
3303
3304          elsif not Overflow_Checks_Suppressed (Ptyp) then
3305             Expand_Pred_Succ (N);
3306          end if;
3307       end Succ;
3308
3309       ---------
3310       -- Tag --
3311       ---------
3312
3313       --  Transforms X'Tag into a direct reference to the tag of X
3314
3315       when Attribute_Tag => Tag :
3316       declare
3317          Ttyp           : Entity_Id;
3318          Prefix_Is_Type : Boolean;
3319
3320       begin
3321          if Is_Entity_Name (Pref) and then Is_Type (Entity (Pref)) then
3322             Ttyp := Entity (Pref);
3323             Prefix_Is_Type := True;
3324          else
3325             Ttyp := Etype (Pref);
3326             Prefix_Is_Type := False;
3327          end if;
3328
3329          if Is_Class_Wide_Type (Ttyp) then
3330             Ttyp := Root_Type (Ttyp);
3331          end if;
3332
3333          Ttyp := Underlying_Type (Ttyp);
3334
3335          if Prefix_Is_Type then
3336
3337             --  For JGNAT we leave the type attribute unexpanded because
3338             --  there's not a dispatching table to reference.
3339
3340             if not Java_VM then
3341                Rewrite (N,
3342                  Unchecked_Convert_To (RTE (RE_Tag),
3343                    New_Reference_To (Access_Disp_Table (Ttyp), Loc)));
3344                Analyze_And_Resolve (N, RTE (RE_Tag));
3345             end if;
3346
3347          else
3348             Rewrite (N,
3349               Make_Selected_Component (Loc,
3350                 Prefix => Relocate_Node (Pref),
3351                 Selector_Name =>
3352                   New_Reference_To (Tag_Component (Ttyp), Loc)));
3353             Analyze_And_Resolve (N, RTE (RE_Tag));
3354          end if;
3355       end Tag;
3356
3357       ----------------
3358       -- Terminated --
3359       ----------------
3360
3361       --  Transforms 'Terminated attribute into a call to Terminated function.
3362
3363       when Attribute_Terminated => Terminated :
3364       begin
3365          if Restricted_Profile then
3366             Rewrite (N,
3367               Build_Call_With_Task (Pref, RTE (RE_Restricted_Terminated)));
3368
3369          else
3370             Rewrite (N,
3371               Build_Call_With_Task (Pref, RTE (RE_Terminated)));
3372          end if;
3373
3374          Analyze_And_Resolve (N, Standard_Boolean);
3375       end Terminated;
3376
3377       ----------------
3378       -- To_Address --
3379       ----------------
3380
3381       --  Transforms System'To_Address (X) into unchecked conversion
3382       --  from (integral) type of X to type address.
3383
3384       when Attribute_To_Address =>
3385          Rewrite (N,
3386            Unchecked_Convert_To (RTE (RE_Address),
3387              Relocate_Node (First (Exprs))));
3388          Analyze_And_Resolve (N, RTE (RE_Address));
3389
3390       ----------------
3391       -- Truncation --
3392       ----------------
3393
3394       --  Transforms 'Truncation into a call to the floating-point attribute
3395       --  function Truncation in Fat_xxx (where xxx is the root type)
3396
3397       when Attribute_Truncation =>
3398          Expand_Fpt_Attribute_R (N);
3399
3400       -----------------------
3401       -- Unbiased_Rounding --
3402       -----------------------
3403
3404       --  Transforms 'Unbiased_Rounding into a call to the floating-point
3405       --  attribute function Unbiased_Rounding in Fat_xxx (where xxx is the
3406       --  root type)
3407
3408       when Attribute_Unbiased_Rounding =>
3409          Expand_Fpt_Attribute_R (N);
3410
3411       ----------------------
3412       -- Unchecked_Access --
3413       ----------------------
3414
3415       when Attribute_Unchecked_Access =>
3416          Expand_Access_To_Type (N);
3417
3418       -----------------
3419       -- UET_Address --
3420       -----------------
3421
3422       when Attribute_UET_Address => UET_Address : declare
3423          Ent : constant Entity_Id :=
3424                  Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
3425
3426       begin
3427          Insert_Action (N,
3428            Make_Object_Declaration (Loc,
3429              Defining_Identifier => Ent,
3430              Aliased_Present     => True,
3431              Object_Definition   =>
3432                New_Occurrence_Of (RTE (RE_Address), Loc)));
3433
3434          --  Construct name __gnat_xxx__SDP, where xxx is the unit name
3435          --  in normal external form.
3436
3437          Get_External_Unit_Name_String (Get_Unit_Name (Pref));
3438          Name_Buffer (1 + 7 .. Name_Len + 7) := Name_Buffer (1 .. Name_Len);
3439          Name_Len := Name_Len + 7;
3440          Name_Buffer (1 .. 7) := "__gnat_";
3441          Name_Buffer (Name_Len + 1 .. Name_Len + 5) := "__SDP";
3442          Name_Len := Name_Len + 5;
3443
3444          Set_Is_Imported (Ent);
3445          Set_Interface_Name (Ent,
3446            Make_String_Literal (Loc,
3447              Strval => String_From_Name_Buffer));
3448
3449          Rewrite (N,
3450            Make_Attribute_Reference (Loc,
3451              Prefix => New_Occurrence_Of (Ent, Loc),
3452              Attribute_Name => Name_Address));
3453
3454          Analyze_And_Resolve (N, Typ);
3455       end UET_Address;
3456
3457       -------------------------
3458       -- Unrestricted_Access --
3459       -------------------------
3460
3461       when Attribute_Unrestricted_Access =>
3462          Expand_Access_To_Type (N);
3463
3464       ---------------
3465       -- VADS_Size --
3466       ---------------
3467
3468       --  The processing for VADS_Size is shared with Size
3469
3470       ---------
3471       -- Val --
3472       ---------
3473
3474       --  For enumeration types with a standard representation, and for all
3475       --  other types, Val is handled by Gigi. For enumeration types with
3476       --  a non-standard representation we use the _Pos_To_Rep array that
3477       --  was created when the type was frozen.
3478
3479       when Attribute_Val => Val :
3480       declare
3481          Etyp : constant Entity_Id := Base_Type (Entity (Pref));
3482
3483       begin
3484          if Is_Enumeration_Type (Etyp)
3485            and then Present (Enum_Pos_To_Rep (Etyp))
3486          then
3487             if Has_Contiguous_Rep (Etyp) then
3488                declare
3489                   Rep_Node : constant Node_Id :=
3490                     Unchecked_Convert_To (Etyp,
3491                        Make_Op_Add (Loc,
3492                          Left_Opnd =>
3493                             Make_Integer_Literal (Loc,
3494                               Enumeration_Rep (First_Literal (Etyp))),
3495                          Right_Opnd =>
3496                           (Convert_To (Standard_Integer,
3497                              Relocate_Node (First (Exprs))))));
3498
3499                begin
3500                   Rewrite (N,
3501                      Unchecked_Convert_To (Etyp,
3502                          Make_Op_Add (Loc,
3503                            Left_Opnd =>
3504                              Make_Integer_Literal (Loc,
3505                                Enumeration_Rep (First_Literal (Etyp))),
3506                            Right_Opnd =>
3507                              Make_Function_Call (Loc,
3508                                Name =>
3509                                  New_Reference_To
3510                                    (TSS (Etyp, TSS_Rep_To_Pos), Loc),
3511                                Parameter_Associations => New_List (
3512                                  Rep_Node,
3513                                  Rep_To_Pos_Flag (Etyp, Loc))))));
3514                end;
3515
3516             else
3517                Rewrite (N,
3518                  Make_Indexed_Component (Loc,
3519                    Prefix => New_Reference_To (Enum_Pos_To_Rep (Etyp), Loc),
3520                    Expressions => New_List (
3521                      Convert_To (Standard_Integer,
3522                        Relocate_Node (First (Exprs))))));
3523             end if;
3524
3525             Analyze_And_Resolve (N, Typ);
3526          end if;
3527       end Val;
3528
3529       -----------
3530       -- Valid --
3531       -----------
3532
3533       --  The code for valid is dependent on the particular types involved.
3534       --  See separate sections below for the generated code in each case.
3535
3536       when Attribute_Valid => Valid :
3537       declare
3538          Ptyp : constant Entity_Id  := Etype (Pref);
3539          Btyp : Entity_Id           := Base_Type (Ptyp);
3540          Tst  : Node_Id;
3541
3542          Save_Validity_Checks_On : constant Boolean := Validity_Checks_On;
3543          --  Save the validity checking mode. We always turn off validity
3544          --  checking during process of 'Valid since this is one place
3545          --  where we do not want the implicit validity checks to intefere
3546          --  with the explicit validity check that the programmer is doing.
3547
3548          function Make_Range_Test return Node_Id;
3549          --  Build the code for a range test of the form
3550          --    Btyp!(Pref) >= Btyp!(Ptyp'First)
3551          --      and then
3552          --    Btyp!(Pref) <= Btyp!(Ptyp'Last)
3553
3554          ---------------------
3555          -- Make_Range_Test --
3556          ---------------------
3557
3558          function Make_Range_Test return Node_Id is
3559          begin
3560             return
3561               Make_And_Then (Loc,
3562                 Left_Opnd =>
3563                   Make_Op_Ge (Loc,
3564                     Left_Opnd =>
3565                       Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
3566
3567                     Right_Opnd =>
3568                       Unchecked_Convert_To (Btyp,
3569                         Make_Attribute_Reference (Loc,
3570                           Prefix => New_Occurrence_Of (Ptyp, Loc),
3571                           Attribute_Name => Name_First))),
3572
3573                 Right_Opnd =>
3574                   Make_Op_Le (Loc,
3575                     Left_Opnd =>
3576                       Unchecked_Convert_To (Btyp,
3577                         Duplicate_Subexpr_No_Checks (Pref)),
3578
3579                     Right_Opnd =>
3580                       Unchecked_Convert_To (Btyp,
3581                         Make_Attribute_Reference (Loc,
3582                           Prefix => New_Occurrence_Of (Ptyp, Loc),
3583                           Attribute_Name => Name_Last))));
3584          end Make_Range_Test;
3585
3586       --  Start of processing for Attribute_Valid
3587
3588       begin
3589          --  Turn off validity checks. We do not want any implicit validity
3590          --  checks to intefere with the explicit check from the attribute
3591
3592          Validity_Checks_On := False;
3593
3594          --  Floating-point case. This case is handled by the Valid attribute
3595          --  code in the floating-point attribute run-time library.
3596
3597          if Is_Floating_Point_Type (Ptyp) then
3598             declare
3599                Rtp : constant Entity_Id := Root_Type (Etype (Pref));
3600
3601             begin
3602                --  If the floating-point object might be unaligned, we need
3603                --  to call the special routine Unaligned_Valid, which makes
3604                --  the needed copy, being careful not to load the value into
3605                --  any floating-point register. The argument in this case is
3606                --  obj'Address (see Unchecked_Valid routine in s-fatgen.ads).
3607
3608                if Is_Possibly_Unaligned_Object (Pref) then
3609                   Set_Attribute_Name (N, Name_Unaligned_Valid);
3610                   Expand_Fpt_Attribute
3611                     (N, Rtp, Name_Unaligned_Valid,
3612                      New_List (
3613                        Make_Attribute_Reference (Loc,
3614                          Prefix         => Relocate_Node (Pref),
3615                          Attribute_Name => Name_Address)));
3616
3617                --  In the normal case where we are sure the object is aligned,
3618                --  we generate a caqll to Valid, and the argument in this case
3619                --  is obj'Unrestricted_Access (after converting obj to the
3620                --  right floating-point type).
3621
3622                else
3623                   Expand_Fpt_Attribute
3624                     (N, Rtp, Name_Valid,
3625                      New_List (
3626                        Make_Attribute_Reference (Loc,
3627                          Prefix         => Unchecked_Convert_To (Rtp, Pref),
3628                          Attribute_Name => Name_Unrestricted_Access)));
3629                end if;
3630
3631                --  One more task, we still need a range check. Required
3632                --  only if we have a constraint, since the Valid routine
3633                --  catches infinities properly (infinities are never valid).
3634
3635                --  The way we do the range check is simply to create the
3636                --  expression: Valid (N) and then Base_Type(Pref) in Typ.
3637
3638                if not Subtypes_Statically_Match (Ptyp, Btyp) then
3639                   Rewrite (N,
3640                     Make_And_Then (Loc,
3641                       Left_Opnd  => Relocate_Node (N),
3642                       Right_Opnd =>
3643                         Make_In (Loc,
3644                           Left_Opnd => Convert_To (Btyp, Pref),
3645                           Right_Opnd => New_Occurrence_Of (Ptyp, Loc))));
3646                end if;
3647             end;
3648
3649          --  Enumeration type with holes
3650
3651          --  For enumeration types with holes, the Pos value constructed by
3652          --  the Enum_Rep_To_Pos function built in Exp_Ch3 called with a
3653          --  second argument of False returns minus one for an invalid value,
3654          --  and the non-negative pos value for a valid value, so the
3655          --  expansion of X'Valid is simply:
3656
3657          --     type(X)'Pos (X) >= 0
3658
3659          --  We can't quite generate it that way because of the requirement
3660          --  for the non-standard second argument of False in the resulting
3661          --  rep_to_pos call, so we have to explicitly create:
3662
3663          --     _rep_to_pos (X, False) >= 0
3664
3665          --  If we have an enumeration subtype, we also check that the
3666          --  value is in range:
3667
3668          --    _rep_to_pos (X, False) >= 0
3669          --      and then
3670          --       (X >= type(X)'First and then type(X)'Last <= X)
3671
3672          elsif Is_Enumeration_Type (Ptyp)
3673            and then Present (Enum_Pos_To_Rep (Base_Type (Ptyp)))
3674          then
3675             Tst :=
3676               Make_Op_Ge (Loc,
3677                 Left_Opnd =>
3678                   Make_Function_Call (Loc,
3679                     Name =>
3680                       New_Reference_To
3681                         (TSS (Base_Type (Ptyp), TSS_Rep_To_Pos), Loc),
3682                     Parameter_Associations => New_List (
3683                       Pref,
3684                       New_Occurrence_Of (Standard_False, Loc))),
3685                 Right_Opnd => Make_Integer_Literal (Loc, 0));
3686
3687             if Ptyp /= Btyp
3688               and then
3689                 (Type_Low_Bound (Ptyp) /= Type_Low_Bound (Btyp)
3690                   or else
3691                  Type_High_Bound (Ptyp) /= Type_High_Bound (Btyp))
3692             then
3693                --  The call to Make_Range_Test will create declarations
3694                --  that need a proper insertion point, but Pref is now
3695                --  attached to a node with no ancestor. Attach to tree
3696                --  even if it is to be rewritten below.
3697
3698                Set_Parent (Tst, Parent (N));
3699
3700                Tst :=
3701                  Make_And_Then (Loc,
3702                    Left_Opnd  => Make_Range_Test,
3703                    Right_Opnd => Tst);
3704             end if;
3705
3706             Rewrite (N, Tst);
3707
3708          --  Fortran convention booleans
3709
3710          --  For the very special case of Fortran convention booleans, the
3711          --  value is always valid, since it is an integer with the semantics
3712          --  that non-zero is true, and any value is permissible.
3713
3714          elsif Is_Boolean_Type (Ptyp)
3715            and then Convention (Ptyp) = Convention_Fortran
3716          then
3717             Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
3718
3719          --  For biased representations, we will be doing an unchecked
3720          --  conversion without unbiasing the result. That means that
3721          --  the range test has to take this into account, and the
3722          --  proper form of the test is:
3723
3724          --    Btyp!(Pref) < Btyp!(Ptyp'Range_Length)
3725
3726          elsif Has_Biased_Representation (Ptyp) then
3727             Btyp := RTE (RE_Unsigned_32);
3728             Rewrite (N,
3729               Make_Op_Lt (Loc,
3730                 Left_Opnd =>
3731                   Unchecked_Convert_To (Btyp, Duplicate_Subexpr (Pref)),
3732                 Right_Opnd =>
3733                   Unchecked_Convert_To (Btyp,
3734                     Make_Attribute_Reference (Loc,
3735                       Prefix => New_Occurrence_Of (Ptyp, Loc),
3736                       Attribute_Name => Name_Range_Length))));
3737
3738          --  For all other scalar types, what we want logically is a
3739          --  range test:
3740
3741          --     X in type(X)'First .. type(X)'Last
3742
3743          --  But that's precisely what won't work because of possible
3744          --  unwanted optimization (and indeed the basic motivation for
3745          --  the Valid attribute is exactly that this test does not work!)
3746          --  What will work is:
3747
3748          --     Btyp!(X) >= Btyp!(type(X)'First)
3749          --       and then
3750          --     Btyp!(X) <= Btyp!(type(X)'Last)
3751
3752          --  where Btyp is an integer type large enough to cover the full
3753          --  range of possible stored values (i.e. it is chosen on the basis
3754          --  of the size of the type, not the range of the values). We write
3755          --  this as two tests, rather than a range check, so that static
3756          --  evaluation will easily remove either or both of the checks if
3757          --  they can be -statically determined to be true (this happens
3758          --  when the type of X is static and the range extends to the full
3759          --  range of stored values).
3760
3761          --  Unsigned types. Note: it is safe to consider only whether the
3762          --  subtype is unsigned, since we will in that case be doing all
3763          --  unsigned comparisons based on the subtype range. Since we use
3764          --  the actual subtype object size, this is appropriate.
3765
3766          --  For example, if we have
3767
3768          --    subtype x is integer range 1 .. 200;
3769          --    for x'Object_Size use 8;
3770
3771          --  Now the base type is signed, but objects of this type are 8
3772          --  bits unsigned, and doing an unsigned test of the range 1 to
3773          --  200 is correct, even though a value greater than 127 looks
3774          --  signed to a signed comparison.
3775
3776          elsif Is_Unsigned_Type (Ptyp) then
3777             if Esize (Ptyp) <= 32 then
3778                Btyp := RTE (RE_Unsigned_32);
3779             else
3780                Btyp := RTE (RE_Unsigned_64);
3781             end if;
3782
3783             Rewrite (N, Make_Range_Test);
3784
3785          --  Signed types
3786
3787          else
3788             if Esize (Ptyp) <= Esize (Standard_Integer) then
3789                Btyp := Standard_Integer;
3790             else
3791                Btyp := Universal_Integer;
3792             end if;
3793
3794             Rewrite (N, Make_Range_Test);
3795          end if;
3796
3797          Analyze_And_Resolve (N, Standard_Boolean);
3798          Validity_Checks_On := Save_Validity_Checks_On;
3799       end Valid;
3800
3801       -----------
3802       -- Value --
3803       -----------
3804
3805       --  Value attribute is handled in separate unti Exp_Imgv
3806
3807       when Attribute_Value =>
3808          Exp_Imgv.Expand_Value_Attribute (N);
3809
3810       -----------------
3811       -- Value_Size --
3812       -----------------
3813
3814       --  The processing for Value_Size shares the processing for Size
3815
3816       -------------
3817       -- Version --
3818       -------------
3819
3820       --  The processing for Version shares the processing for Body_Version
3821
3822       ----------------
3823       -- Wide_Image --
3824       ----------------
3825
3826       --  We expand typ'Wide_Image (X) into
3827
3828       --    String_To_Wide_String
3829       --      (typ'Image (X), Wide_Character_Encoding_Method)
3830
3831       --  This works in all cases because String_To_Wide_String converts any
3832       --  wide character escape sequences resulting from the Image call to the
3833       --  proper Wide_Character equivalent
3834
3835       --  not quite right for typ = Wide_Character ???
3836
3837       when Attribute_Wide_Image => Wide_Image :
3838       begin
3839          Rewrite (N,
3840            Make_Function_Call (Loc,
3841              Name => New_Reference_To (RTE (RE_String_To_Wide_String), Loc),
3842              Parameter_Associations => New_List (
3843                Make_Attribute_Reference (Loc,
3844                  Prefix         => Pref,
3845                  Attribute_Name => Name_Image,
3846                  Expressions    => Exprs),
3847
3848                Make_Integer_Literal (Loc,
3849                  Intval => Int (Wide_Character_Encoding_Method)))));
3850
3851          Analyze_And_Resolve (N, Standard_Wide_String);
3852       end Wide_Image;
3853
3854       ----------------
3855       -- Wide_Value --
3856       ----------------
3857
3858       --  We expand typ'Wide_Value (X) into
3859
3860       --    typ'Value
3861       --      (Wide_String_To_String (X, Wide_Character_Encoding_Method))
3862
3863       --  Wide_String_To_String is a runtime function that converts its wide
3864       --  string argument to String, converting any non-translatable characters
3865       --  into appropriate escape sequences. This preserves the required
3866       --  semantics of Wide_Value in all cases, and results in a very simple
3867       --  implementation approach.
3868
3869       --  It's not quite right where typ = Wide_Character, because the encoding
3870       --  method may not cover the whole character type ???
3871
3872       when Attribute_Wide_Value => Wide_Value :
3873       begin
3874          Rewrite (N,
3875            Make_Attribute_Reference (Loc,
3876              Prefix         => Pref,
3877              Attribute_Name => Name_Value,
3878
3879              Expressions    => New_List (
3880                Make_Function_Call (Loc,
3881                  Name =>
3882                    New_Reference_To (RTE (RE_Wide_String_To_String), Loc),
3883
3884                  Parameter_Associations => New_List (
3885                    Relocate_Node (First (Exprs)),
3886                    Make_Integer_Literal (Loc,
3887                      Intval => Int (Wide_Character_Encoding_Method)))))));
3888
3889          Analyze_And_Resolve (N, Typ);
3890       end Wide_Value;
3891
3892       ----------------
3893       -- Wide_Width --
3894       ----------------
3895
3896       --  Wide_Width attribute is handled in separate unit Exp_Imgv
3897
3898       when Attribute_Wide_Width =>
3899          Exp_Imgv.Expand_Width_Attribute (N, Wide => True);
3900
3901       -----------
3902       -- Width --
3903       -----------
3904
3905       --  Width attribute is handled in separate unit Exp_Imgv
3906
3907       when Attribute_Width =>
3908          Exp_Imgv.Expand_Width_Attribute (N, Wide => False);
3909
3910       -----------
3911       -- Write --
3912       -----------
3913
3914       when Attribute_Write => Write : declare
3915          P_Type : constant Entity_Id := Entity (Pref);
3916          U_Type : constant Entity_Id := Underlying_Type (P_Type);
3917          Pname  : Entity_Id;
3918          Decl   : Node_Id;
3919          Prag   : Node_Id;
3920          Arg3   : Node_Id;
3921          Wfunc  : Node_Id;
3922
3923       begin
3924          --  If no underlying type, we have an error that will be diagnosed
3925          --  elsewhere, so here we just completely ignore the expansion.
3926
3927          if No (U_Type) then
3928             return;
3929          end if;
3930
3931          --  The simple case, if there is a TSS for Write, just call it
3932
3933          Pname := Find_Stream_Subprogram (P_Type, TSS_Stream_Write);
3934
3935          if Present (Pname) then
3936             null;
3937
3938          else
3939             --  If there is a Stream_Convert pragma, use it, we rewrite
3940
3941             --     sourcetyp'Output (stream, Item)
3942
3943             --  as
3944
3945             --     strmtyp'Output (Stream, strmwrite (acttyp (Item)));
3946
3947             --  where strmwrite is the given Write function that converts
3948             --  an argument of type sourcetyp or a type acctyp, from which
3949             --  it is derived to type strmtyp. The conversion to acttyp is
3950             --  required for the derived case.
3951
3952             Prag :=
3953               Get_Rep_Pragma
3954                 (Implementation_Base_Type (P_Type), Name_Stream_Convert);
3955
3956             if Present (Prag) then
3957                Arg3 :=
3958                  Next (Next (First (Pragma_Argument_Associations (Prag))));
3959                Wfunc := Entity (Expression (Arg3));
3960
3961                Rewrite (N,
3962                  Make_Attribute_Reference (Loc,
3963                    Prefix => New_Occurrence_Of (Etype (Wfunc), Loc),
3964                    Attribute_Name => Name_Output,
3965                    Expressions => New_List (
3966                      Relocate_Node (First (Exprs)),
3967                      Make_Function_Call (Loc,
3968                        Name => New_Occurrence_Of (Wfunc, Loc),
3969                        Parameter_Associations => New_List (
3970                          Convert_To (Etype (First_Formal (Wfunc)),
3971                            Relocate_Node (Next (First (Exprs)))))))));
3972
3973                Analyze (N);
3974                return;
3975
3976             --  For elementary types, we call the W_xxx routine directly
3977
3978             elsif Is_Elementary_Type (U_Type) then
3979                Rewrite (N, Build_Elementary_Write_Call (N));
3980                Analyze (N);
3981                return;
3982
3983             --  Array type case
3984
3985             elsif Is_Array_Type (U_Type) then
3986                Build_Array_Write_Procedure (N, U_Type, Decl, Pname);
3987                Compile_Stream_Body_In_Scope (N, Decl, U_Type, Check => False);
3988
3989             --  Tagged type case, use the primitive Write function. Note that
3990             --  this will dispatch in the class-wide case which is what we want
3991
3992             elsif Is_Tagged_Type (U_Type) then
3993                Pname := Find_Prim_Op (U_Type, TSS_Stream_Write);
3994
3995             --  All other record type cases, including protected records.
3996             --  The latter only arise for expander generated code for
3997             --  handling shared passive partition access.
3998
3999             else
4000                pragma Assert
4001                  (Is_Record_Type (U_Type) or else Is_Protected_Type (U_Type));
4002
4003                --  Ada 2005 (AI-216): Program_Error is raised when executing
4004                --  the default implementation of the Write attribute of an
4005                --  Unchecked_Union type.
4006
4007                if Is_Unchecked_Union (Base_Type (U_Type)) then
4008                   Insert_Action (N,
4009                     Make_Raise_Program_Error (Loc,
4010                       Reason => PE_Unchecked_Union_Restriction));
4011                end if;
4012
4013                if Has_Discriminants (U_Type)
4014                  and then Present
4015                    (Discriminant_Default_Value (First_Discriminant (U_Type)))
4016                then
4017                   Build_Mutable_Record_Write_Procedure
4018                     (Loc, Base_Type (U_Type), Decl, Pname);
4019                else
4020                   Build_Record_Write_Procedure
4021                     (Loc, Base_Type (U_Type), Decl, Pname);
4022                end if;
4023
4024                Insert_Action (N, Decl);
4025             end if;
4026          end if;
4027
4028          --  If we fall through, Pname is the procedure to be called
4029
4030          Rewrite_Stream_Proc_Call (Pname);
4031       end Write;
4032
4033       --  Component_Size is handled by Gigi, unless the component size is
4034       --  known at compile time, which is always true in the packed array
4035       --  case. It is important that the packed array case is handled in
4036       --  the front end (see Eval_Attribute) since Gigi would otherwise
4037       --  get confused by the equivalent packed array type.
4038
4039       when Attribute_Component_Size =>
4040          null;
4041
4042       --  The following attributes are handled by Gigi (except that static
4043       --  cases have already been evaluated by the semantics, but in any
4044       --  case Gigi should not count on that).
4045
4046       --  In addition Gigi handles the non-floating-point cases of Pred
4047       --  and Succ (including the fixed-point cases, which can just be
4048       --  treated as integer increment/decrement operations)
4049
4050       --  Gigi also handles the non-class-wide cases of Size
4051
4052       when Attribute_Bit_Order                    |
4053            Attribute_Code_Address                 |
4054            Attribute_Definite                     |
4055            Attribute_Max                          |
4056            Attribute_Mechanism_Code               |
4057            Attribute_Min                          |
4058            Attribute_Null_Parameter               |
4059            Attribute_Passed_By_Reference          |
4060            Attribute_Pool_Address                 =>
4061          null;
4062
4063       --  The following attributes are also handled by Gigi, but return a
4064       --  universal integer result, so may need a conversion for checking
4065       --  that the result is in range.
4066
4067       when Attribute_Aft                          |
4068            Attribute_Bit                          |
4069            Attribute_Max_Size_In_Storage_Elements
4070       =>
4071          Apply_Universal_Integer_Attribute_Checks (N);
4072
4073       --  The following attributes should not appear at this stage, since they
4074       --  have already been handled by the analyzer (and properly rewritten
4075       --  with corresponding values or entities to represent the right values)
4076
4077       when Attribute_Abort_Signal                 |
4078            Attribute_Address_Size                 |
4079            Attribute_Base                         |
4080            Attribute_Class                        |
4081            Attribute_Default_Bit_Order            |
4082            Attribute_Delta                        |
4083            Attribute_Denorm                       |
4084            Attribute_Digits                       |
4085            Attribute_Emax                         |
4086            Attribute_Epsilon                      |
4087            Attribute_Has_Access_Values            |
4088            Attribute_Has_Discriminants            |
4089            Attribute_Large                        |
4090            Attribute_Machine_Emax                 |
4091            Attribute_Machine_Emin                 |
4092            Attribute_Machine_Mantissa             |
4093            Attribute_Machine_Overflows            |
4094            Attribute_Machine_Radix                |
4095            Attribute_Machine_Rounds               |
4096            Attribute_Maximum_Alignment            |
4097            Attribute_Model_Emin                   |
4098            Attribute_Model_Epsilon                |
4099            Attribute_Model_Mantissa               |
4100            Attribute_Model_Small                  |
4101            Attribute_Modulus                      |
4102            Attribute_Partition_ID                 |
4103            Attribute_Range                        |
4104            Attribute_Safe_Emax                    |
4105            Attribute_Safe_First                   |
4106            Attribute_Safe_Large                   |
4107            Attribute_Safe_Last                    |
4108            Attribute_Safe_Small                   |
4109            Attribute_Scale                        |
4110            Attribute_Signed_Zeros                 |
4111            Attribute_Small                        |
4112            Attribute_Storage_Unit                 |
4113            Attribute_Target_Name                  |
4114            Attribute_Type_Class                   |
4115            Attribute_Unconstrained_Array          |
4116            Attribute_Universal_Literal_String     |
4117            Attribute_Wchar_T_Size                 |
4118            Attribute_Word_Size                    =>
4119
4120          raise Program_Error;
4121
4122       --  The Asm_Input and Asm_Output attributes are not expanded at this
4123       --  stage, but will be eliminated in the expansion of the Asm call,
4124       --  see Exp_Intr for details. So Gigi will never see these either.
4125
4126       when Attribute_Asm_Input                    |
4127            Attribute_Asm_Output                   =>
4128
4129          null;
4130
4131       end case;
4132
4133    exception
4134       when RE_Not_Available =>
4135          return;
4136    end Expand_N_Attribute_Reference;
4137
4138    ----------------------
4139    -- Expand_Pred_Succ --
4140    ----------------------
4141
4142    --  For typ'Pred (exp), we generate the check
4143
4144    --    [constraint_error when exp = typ'Base'First]
4145
4146    --  Similarly, for typ'Succ (exp), we generate the check
4147
4148    --    [constraint_error when exp = typ'Base'Last]
4149
4150    --  These checks are not generated for modular types, since the proper
4151    --  semantics for Succ and Pred on modular types is to wrap, not raise CE.
4152
4153    procedure Expand_Pred_Succ (N : Node_Id) is
4154       Loc  : constant Source_Ptr := Sloc (N);
4155       Cnam : Name_Id;
4156
4157    begin
4158       if Attribute_Name (N) = Name_Pred then
4159          Cnam := Name_First;
4160       else
4161          Cnam := Name_Last;
4162       end if;
4163
4164       Insert_Action (N,
4165         Make_Raise_Constraint_Error (Loc,
4166           Condition =>
4167             Make_Op_Eq (Loc,
4168               Left_Opnd =>
4169                 Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
4170               Right_Opnd =>
4171                 Make_Attribute_Reference (Loc,
4172                   Prefix =>
4173                     New_Reference_To (Base_Type (Etype (Prefix (N))), Loc),
4174                   Attribute_Name => Cnam)),
4175           Reason => CE_Overflow_Check_Failed));
4176
4177    end Expand_Pred_Succ;
4178
4179    ------------------------
4180    -- Find_Inherited_TSS --
4181    ------------------------
4182
4183    function Find_Inherited_TSS
4184      (Typ : Entity_Id;
4185       Nam : TSS_Name_Type) return Entity_Id
4186    is
4187       Btyp : Entity_Id := Typ;
4188       Proc : Entity_Id;
4189
4190    begin
4191       loop
4192          Btyp := Base_Type (Btyp);
4193          Proc :=  TSS (Btyp, Nam);
4194
4195          exit when Present (Proc)
4196            or else not Is_Derived_Type (Btyp);
4197
4198          --  If Typ is a derived type, it may inherit attributes from
4199          --  some ancestor.
4200
4201          Btyp := Etype (Btyp);
4202       end loop;
4203
4204       if No (Proc) then
4205
4206          --  If nothing else, use the TSS of the root type
4207
4208          Proc := TSS (Base_Type (Underlying_Type (Typ)), Nam);
4209       end if;
4210
4211       return Proc;
4212
4213    end Find_Inherited_TSS;
4214
4215    ----------------------------
4216    -- Find_Stream_Subprogram --
4217    ----------------------------
4218
4219    function Find_Stream_Subprogram
4220      (Typ : Entity_Id;
4221       Nam : TSS_Name_Type) return Entity_Id is
4222    begin
4223       if Is_Tagged_Type (Typ)
4224         and then Is_Derived_Type (Typ)
4225       then
4226          return Find_Prim_Op (Typ, Nam);
4227       else
4228          return Find_Inherited_TSS (Typ, Nam);
4229       end if;
4230    end Find_Stream_Subprogram;
4231
4232    -----------------------
4233    -- Get_Index_Subtype --
4234    -----------------------
4235
4236    function Get_Index_Subtype (N : Node_Id) return Node_Id is
4237       P_Type : Entity_Id := Etype (Prefix (N));
4238       Indx   : Node_Id;
4239       J      : Int;
4240
4241    begin
4242       if Is_Access_Type (P_Type) then
4243          P_Type := Designated_Type (P_Type);
4244       end if;
4245
4246       if No (Expressions (N)) then
4247          J := 1;
4248       else
4249          J := UI_To_Int (Expr_Value (First (Expressions (N))));
4250       end if;
4251
4252       Indx := First_Index (P_Type);
4253       while J > 1 loop
4254          Next_Index (Indx);
4255          J := J - 1;
4256       end loop;
4257
4258       return Etype (Indx);
4259    end Get_Index_Subtype;
4260
4261    ---------------------------------
4262    -- Is_Constrained_Packed_Array --
4263    ---------------------------------
4264
4265    function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean is
4266       Arr : Entity_Id := Typ;
4267
4268    begin
4269       if Is_Access_Type (Arr) then
4270          Arr := Designated_Type (Arr);
4271       end if;
4272
4273       return Is_Array_Type (Arr)
4274         and then Is_Constrained (Arr)
4275         and then Present (Packed_Array_Type (Arr));
4276    end Is_Constrained_Packed_Array;
4277
4278 end Exp_Attr;