gcc/ada/exp_attr.adb

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