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