gcc/ada/exp_imgv.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ I M G V                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2001-2017, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Casing;   use Casing;
  28 with Checks;   use Checks;
  29 with Einfo;    use Einfo;
  30 with Exp_Util; use Exp_Util;
  31 with Lib;      use Lib;
  32 with Namet;    use Namet;
  33 with Nmake;    use Nmake;
  34 with Nlists;   use Nlists;
  35 with Opt;      use Opt;
  36 with Rtsfind;  use Rtsfind;
  37 with Sem_Aux;  use Sem_Aux;
  38 with Sem_Res;  use Sem_Res;
  39 with Sem_Util; use Sem_Util;
  40 with Sinfo;    use Sinfo;
  41 with Snames;   use Snames;
  42 with Stand;    use Stand;
  43 with Stringt;  use Stringt;
  44 with Tbuild;   use Tbuild;
  45 with Ttypes;   use Ttypes;
  46 with Uintp;    use Uintp;
  47 with Urealp;   use Urealp;
  48
  49 package body Exp_Imgv is
  50
  51    function Has_Decimal_Small (E : Entity_Id) return Boolean;
  52    --  Applies to all entities. True for a Decimal_Fixed_Point_Type, or an
  53    --  Ordinary_Fixed_Point_Type with a small that is a negative power of ten.
  54    --  Shouldn't this be in einfo.adb or sem_aux.adb???
  55
  56    procedure Rewrite_Object_Image
  57      (N         : Node_Id;
  58       Pref      : Entity_Id;
  59       Attr_Name : Name_Id;
  60       Str_Typ   : Entity_Id);
  61    --  AI12-00124: Rewrite attribute 'Image when it is applied to an object
  62    --  reference as an attribute applied to a type. N denotes the node to be
  63    --  rewritten, Pref denotes the prefix of the 'Image attribute, and Name
  64    --  and Str_Typ specify which specific string type and 'Image attribute to
  65    --  apply (e.g. Name_Wide_Image and Standard_Wide_String).
  66
  67    ------------------------------------
  68    -- Build_Enumeration_Image_Tables --
  69    ------------------------------------
  70
  71    procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is
  72       Loc  : constant Source_Ptr := Sloc (E);
  73       Str  : String_Id;
  74       Ind  : List_Id;
  75       Lit  : Entity_Id;
  76       Nlit : Nat;
  77       Len  : Nat;
  78       Estr : Entity_Id;
  79       Eind : Entity_Id;
  80       Ityp : Node_Id;
  81
  82    begin
  83       --  Nothing to do for other than a root enumeration type
  84
  85       if E /= Root_Type (E) then
  86          return;
  87
  88       --  Nothing to do if pragma Discard_Names applies
  89
  90       elsif Discard_Names (E) then
  91          return;
  92       end if;
  93
  94       --  Otherwise tables need constructing
  95
  96       Start_String;
  97       Ind := New_List;
  98       Lit := First_Literal (E);
  99       Len := 1;
 100       Nlit := 0;
 101
 102       loop
 103          Append_To (Ind,
 104            Make_Integer_Literal (Loc, UI_From_Int (Len)));
 105
 106          exit when No (Lit);
 107          Nlit := Nlit + 1;
 108
 109          Get_Unqualified_Decoded_Name_String (Chars (Lit));
 110
 111          if Name_Buffer (1) /= ''' then
 112             Set_Casing (All_Upper_Case);
 113          end if;
 114
 115          Store_String_Chars (Name_Buffer (1 .. Name_Len));
 116          Len := Len + Int (Name_Len);
 117          Next_Literal (Lit);
 118       end loop;
 119
 120       if Len < Int (2 ** (8 - 1)) then
 121          Ityp := Standard_Integer_8;
 122       elsif Len < Int (2 ** (16 - 1)) then
 123          Ityp := Standard_Integer_16;
 124       else
 125          Ityp := Standard_Integer_32;
 126       end if;
 127
 128       Str := End_String;
 129
 130       Estr :=
 131         Make_Defining_Identifier (Loc,
 132           Chars => New_External_Name (Chars (E), 'S'));
 133
 134       Eind :=
 135         Make_Defining_Identifier (Loc,
 136           Chars => New_External_Name (Chars (E), 'N'));
 137
 138       Set_Lit_Strings (E, Estr);
 139       Set_Lit_Indexes (E, Eind);
 140
 141       Insert_Actions (N,
 142         New_List (
 143           Make_Object_Declaration (Loc,
 144             Defining_Identifier => Estr,
 145             Constant_Present    => True,
 146             Object_Definition   =>
 147               New_Occurrence_Of (Standard_String, Loc),
 148             Expression          =>
 149               Make_String_Literal (Loc,
 150                 Strval => Str)),
 151
 152           Make_Object_Declaration (Loc,
 153             Defining_Identifier => Eind,
 154             Constant_Present    => True,
 155
 156             Object_Definition =>
 157               Make_Constrained_Array_Definition (Loc,
 158                 Discrete_Subtype_Definitions => New_List (
 159                   Make_Range (Loc,
 160                     Low_Bound  => Make_Integer_Literal (Loc, 0),
 161                     High_Bound => Make_Integer_Literal (Loc, Nlit))),
 162                 Component_Definition =>
 163                   Make_Component_Definition (Loc,
 164                     Aliased_Present    => False,
 165                     Subtype_Indication => New_Occurrence_Of (Ityp, Loc))),
 166
 167             Expression          =>
 168               Make_Aggregate (Loc,
 169                 Expressions => Ind))),
 170         Suppress => All_Checks);
 171    end Build_Enumeration_Image_Tables;
 172
 173    ----------------------------
 174    -- Expand_Image_Attribute --
 175    ----------------------------
 176
 177    --  For all cases other than user defined enumeration types, the scheme
 178    --  is as follows. First we insert the following code:
 179
 180    --    Snn : String (1 .. rt'Width);
 181    --    Pnn : Natural;
 182    --    Image_xx (tv, Snn, Pnn [,pm]);
 183    --
 184    --  and then Expr is replaced by Snn (1 .. Pnn)
 185
 186    --  In the above expansion:
 187
 188    --    rt is the root type of the expression
 189    --    tv is the expression with the value, usually a type conversion
 190    --    pm is an extra parameter present in some cases
 191
 192    --  The following table shows tv, xx, and (if used) pm for the various
 193    --  possible types of the argument:
 194
 195    --    For types whose root type is Character
 196    --      xx = Character
 197    --      tv = Character (Expr)
 198
 199    --    For types whose root type is Boolean
 200    --      xx = Boolean
 201    --      tv = Boolean (Expr)
 202
 203    --    For signed integer types with size <= Integer'Size
 204    --      xx = Integer
 205    --      tv = Integer (Expr)
 206
 207    --    For other signed integer types
 208    --      xx = Long_Long_Integer
 209    --      tv = Long_Long_Integer (Expr)
 210
 211    --    For modular types with modulus <= System.Unsigned_Types.Unsigned
 212    --      xx = Unsigned
 213    --      tv = System.Unsigned_Types.Unsigned (Expr)
 214
 215    --    For other modular integer types
 216    --      xx = Long_Long_Unsigned
 217    --      tv = System.Unsigned_Types.Long_Long_Unsigned (Expr)
 218
 219    --    For types whose root type is Wide_Character
 220    --      xx = Wide_Character
 221    --      tv = Wide_Character (Expr)
 222    --      pm = Boolean, true if Ada 2005 mode, False otherwise
 223
 224    --    For types whose root type is Wide_Wide_Character
 225    --      xx = Wide_Wide_Character
 226    --      tv = Wide_Wide_Character (Expr)
 227
 228    --    For floating-point types
 229    --      xx = Floating_Point
 230    --      tv = Long_Long_Float (Expr)
 231    --      pm = typ'Digits (typ = subtype of expression)
 232
 233    --    For ordinary fixed-point types
 234    --      xx = Ordinary_Fixed_Point
 235    --      tv = Long_Long_Float (Expr)
 236    --      pm = typ'Aft (typ = subtype of expression)
 237
 238    --    For decimal fixed-point types with size = Integer'Size
 239    --      xx = Decimal
 240    --      tv = Integer (Expr)
 241    --      pm = typ'Scale (typ = subtype of expression)
 242
 243    --    For decimal fixed-point types with size > Integer'Size
 244    --      xx = Long_Long_Decimal
 245    --      tv = Long_Long_Integer?(Expr) [convert with no scaling]
 246    --      pm = typ'Scale (typ = subtype of expression)
 247
 248    --  For enumeration types other than those declared packages Standard
 249    --  or System, Snn, Pnn, are expanded as above, but the call looks like:
 250
 251    --    Image_Enumeration_NN (rt'Pos (X), Snn, Pnn, typS, typI'Address)
 252
 253    --  where rt is the root type of the expression, and typS and typI are
 254    --  the entities constructed as described in the spec for the procedure
 255    --  Build_Enumeration_Image_Tables and NN is 32/16/8 depending on the
 256    --  element type of Lit_Indexes. The rewriting of the expression to
 257    --  Snn (1 .. Pnn) then occurs as in the other cases. A special case is
 258    --  when pragma Discard_Names applies, in which case we replace expr by:
 259
 260    --     (rt'Pos (expr))'Img
 261
 262    --  So that the result is a space followed by the decimal value for the
 263    --  position of the enumeration value in the enumeration type.
 264
 265    procedure Expand_Image_Attribute (N : Node_Id) is
 266       Loc       : constant Source_Ptr := Sloc (N);
 267       Exprs     : constant List_Id    := Expressions (N);
 268       Pref      : constant Node_Id    := Prefix (N);
 269       Expr      : constant Node_Id    := Relocate_Node (First (Exprs));
 270       Imid      : RE_Id;
 271       Ptyp      : Entity_Id;
 272       Rtyp      : Entity_Id;
 273       Tent      : Entity_Id;
 274       Ttyp      : Entity_Id;
 275       Proc_Ent  : Entity_Id;
 276       Enum_Case : Boolean;
 277
 278       Arg_List : List_Id;
 279       --  List of arguments for run-time procedure call
 280
 281       Ins_List : List_Id;
 282       --  List of actions to be inserted
 283
 284       Snn : constant Entity_Id := Make_Temporary (Loc, 'S');
 285       Pnn : constant Entity_Id := Make_Temporary (Loc, 'P');
 286
 287    begin
 288       if Is_Object_Image (Pref) then
 289          Rewrite_Object_Image (N, Pref, Name_Image, Standard_String);
 290          return;
 291       end if;
 292
 293       Ptyp := Entity (Pref);
 294       Rtyp := Root_Type (Ptyp);
 295
 296       --  Build declarations of Snn and Pnn to be inserted
 297
 298       Ins_List := New_List (
 299
 300          --  Snn : String (1 .. typ'Width);
 301
 302          Make_Object_Declaration (Loc,
 303             Defining_Identifier => Snn,
 304             Object_Definition   =>
 305               Make_Subtype_Indication (Loc,
 306                 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
 307                 Constraint   =>
 308                   Make_Index_Or_Discriminant_Constraint (Loc,
 309                     Constraints => New_List (
 310                       Make_Range (Loc,
 311                         Low_Bound  => Make_Integer_Literal (Loc, 1),
 312                         High_Bound =>
 313                           Make_Attribute_Reference (Loc,
 314                             Prefix         => New_Occurrence_Of (Rtyp, Loc),
 315                             Attribute_Name => Name_Width)))))),
 316
 317          --  Pnn : Natural;
 318
 319          Make_Object_Declaration (Loc,
 320            Defining_Identifier => Pnn,
 321            Object_Definition   => New_Occurrence_Of (Standard_Natural, Loc)));
 322
 323       --  Set Imid (RE_Id of procedure to call), and Tent, target for the
 324       --  type conversion of the first argument for all possibilities.
 325
 326       Enum_Case := False;
 327
 328       if Rtyp = Standard_Boolean then
 329          Imid := RE_Image_Boolean;
 330          Tent := Rtyp;
 331
 332       --  For standard character, we have to select the version which handles
 333       --  soft hyphen correctly, based on the version of Ada in use (this is
 334       --  ugly, but we have no choice).
 335
 336       elsif Rtyp = Standard_Character then
 337          if Ada_Version < Ada_2005 then
 338             Imid := RE_Image_Character;
 339          else
 340             Imid := RE_Image_Character_05;
 341          end if;
 342
 343          Tent := Rtyp;
 344
 345       elsif Rtyp = Standard_Wide_Character then
 346          Imid := RE_Image_Wide_Character;
 347          Tent := Rtyp;
 348
 349       elsif Rtyp = Standard_Wide_Wide_Character then
 350          Imid := RE_Image_Wide_Wide_Character;
 351          Tent := Rtyp;
 352
 353       elsif Is_Signed_Integer_Type (Rtyp) then
 354          if Esize (Rtyp) <= Esize (Standard_Integer) then
 355             Imid := RE_Image_Integer;
 356             Tent := Standard_Integer;
 357          else
 358             Imid := RE_Image_Long_Long_Integer;
 359             Tent := Standard_Long_Long_Integer;
 360          end if;
 361
 362       elsif Is_Modular_Integer_Type (Rtyp) then
 363          if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
 364             Imid := RE_Image_Unsigned;
 365             Tent := RTE (RE_Unsigned);
 366          else
 367             Imid := RE_Image_Long_Long_Unsigned;
 368             Tent := RTE (RE_Long_Long_Unsigned);
 369          end if;
 370
 371       elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then
 372          if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
 373             Imid := RE_Image_Decimal;
 374             Tent := Standard_Integer;
 375          else
 376             Imid := RE_Image_Long_Long_Decimal;
 377             Tent := Standard_Long_Long_Integer;
 378          end if;
 379
 380       elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
 381          Imid := RE_Image_Ordinary_Fixed_Point;
 382          Tent := Standard_Long_Long_Float;
 383
 384       elsif Is_Floating_Point_Type (Rtyp) then
 385          Imid := RE_Image_Floating_Point;
 386          Tent := Standard_Long_Long_Float;
 387
 388       --  Only other possibility is user defined enumeration type
 389
 390       else
 391          if Discard_Names (First_Subtype (Ptyp))
 392            or else No (Lit_Strings (Root_Type (Ptyp)))
 393          then
 394             --  When pragma Discard_Names applies to the first subtype, build
 395             --  (Pref'Pos (Expr))'Img.
 396
 397             Rewrite (N,
 398               Make_Attribute_Reference (Loc,
 399                 Prefix =>
 400                    Make_Attribute_Reference (Loc,
 401                      Prefix         => Pref,
 402                      Attribute_Name => Name_Pos,
 403                      Expressions    => New_List (Expr)),
 404                 Attribute_Name =>
 405                   Name_Img));
 406             Analyze_And_Resolve (N, Standard_String);
 407             return;
 408
 409          else
 410             --  Here for enumeration type case
 411
 412             Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
 413
 414             if Ttyp = Standard_Integer_8 then
 415                Imid := RE_Image_Enumeration_8;
 416
 417             elsif Ttyp = Standard_Integer_16 then
 418                Imid := RE_Image_Enumeration_16;
 419
 420             else
 421                Imid := RE_Image_Enumeration_32;
 422             end if;
 423
 424             --  Apply a validity check, since it is a bit drastic to get a
 425             --  completely junk image value for an invalid value.
 426
 427             if not Expr_Known_Valid (Expr) then
 428                Insert_Valid_Check (Expr);
 429             end if;
 430
 431             Enum_Case := True;
 432          end if;
 433       end if;
 434
 435       --  Build first argument for call
 436
 437       if Enum_Case then
 438          Arg_List := New_List (
 439            Make_Attribute_Reference (Loc,
 440              Attribute_Name => Name_Pos,
 441              Prefix         => New_Occurrence_Of (Ptyp, Loc),
 442              Expressions    => New_List (Expr)));
 443
 444       else
 445          Arg_List := New_List (Convert_To (Tent, Expr));
 446       end if;
 447
 448       --  Append Snn, Pnn arguments
 449
 450       Append_To (Arg_List, New_Occurrence_Of (Snn, Loc));
 451       Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc));
 452
 453       --  Get entity of procedure to call
 454
 455       Proc_Ent := RTE (Imid);
 456
 457       --  If the procedure entity is empty, that means we have a case in
 458       --  no run time mode where the operation is not allowed, and an
 459       --  appropriate diagnostic has already been issued.
 460
 461       if No (Proc_Ent) then
 462          return;
 463       end if;
 464
 465       --  Otherwise complete preparation of arguments for run-time call
 466
 467       --  Add extra arguments for Enumeration case
 468
 469       if Enum_Case then
 470          Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
 471          Append_To (Arg_List,
 472            Make_Attribute_Reference (Loc,
 473              Prefix         => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
 474              Attribute_Name => Name_Address));
 475
 476       --  For floating-point types, append Digits argument
 477
 478       elsif Is_Floating_Point_Type (Rtyp) then
 479          Append_To (Arg_List,
 480            Make_Attribute_Reference (Loc,
 481              Prefix         => New_Occurrence_Of (Ptyp, Loc),
 482              Attribute_Name => Name_Digits));
 483
 484       --  For ordinary fixed-point types, append Aft parameter
 485
 486       elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
 487          Append_To (Arg_List,
 488            Make_Attribute_Reference (Loc,
 489              Prefix         => New_Occurrence_Of (Ptyp, Loc),
 490              Attribute_Name => Name_Aft));
 491
 492          if Has_Decimal_Small (Rtyp) then
 493             Set_Conversion_OK (First (Arg_List));
 494             Set_Etype (First (Arg_List), Tent);
 495          end if;
 496
 497       --  For decimal, append Scale and also set to do literal conversion
 498
 499       elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
 500          Append_To (Arg_List,
 501            Make_Attribute_Reference (Loc,
 502              Prefix         => New_Occurrence_Of (Ptyp, Loc),
 503              Attribute_Name => Name_Scale));
 504
 505          Set_Conversion_OK (First (Arg_List));
 506          Set_Etype (First (Arg_List), Tent);
 507
 508       --  For Wide_Character, append Ada 2005 indication
 509
 510       elsif Rtyp = Standard_Wide_Character then
 511          Append_To (Arg_List,
 512            New_Occurrence_Of
 513              (Boolean_Literals (Ada_Version >= Ada_2005), Loc));
 514       end if;
 515
 516       --  Now append the procedure call to the insert list
 517
 518       Append_To (Ins_List,
 519          Make_Procedure_Call_Statement (Loc,
 520           Name                   => New_Occurrence_Of (Proc_Ent, Loc),
 521           Parameter_Associations => Arg_List));
 522
 523       --  Insert declarations of Snn, Pnn, and the procedure call. We suppress
 524       --  checks because we are sure that everything is in range at this stage.
 525
 526       Insert_Actions (N, Ins_List, Suppress => All_Checks);
 527
 528       --  Final step is to rewrite the expression as a slice and analyze,
 529       --  again with no checks, since we are sure that everything is OK.
 530
 531       Rewrite (N,
 532         Make_Slice (Loc,
 533           Prefix         => New_Occurrence_Of (Snn, Loc),
 534           Discrete_Range =>
 535             Make_Range (Loc,
 536               Low_Bound  => Make_Integer_Literal (Loc, 1),
 537               High_Bound => New_Occurrence_Of (Pnn, Loc))));
 538
 539       Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
 540    end Expand_Image_Attribute;
 541
 542    ----------------------------
 543    -- Expand_Value_Attribute --
 544    ----------------------------
 545
 546    --  For scalar types derived from Boolean, Character and integer types
 547    --  in package Standard, typ'Value (X) expands into:
 548
 549    --    btyp (Value_xx (X))
 550
 551    --  where btyp is he base type of the prefix
 552
 553    --    For types whose root type is Character
 554    --      xx = Character
 555
 556    --    For types whose root type is Wide_Character
 557    --      xx = Wide_Character
 558
 559    --    For types whose root type is Wide_Wide_Character
 560    --      xx = Wide_Wide_Character
 561
 562    --    For types whose root type is Boolean
 563    --      xx = Boolean
 564
 565    --    For signed integer types with size <= Integer'Size
 566    --      xx = Integer
 567
 568    --    For other signed integer types
 569    --      xx = Long_Long_Integer
 570
 571    --    For modular types with modulus <= System.Unsigned_Types.Unsigned
 572    --      xx = Unsigned
 573
 574    --    For other modular integer types
 575    --      xx = Long_Long_Unsigned
 576
 577    --    For floating-point types and ordinary fixed-point types
 578    --      xx = Real
 579
 580    --  For Wide_[Wide_]Character types, typ'Value (X) expands into:
 581
 582    --    btyp (Value_xx (X, EM))
 583
 584    --  where btyp is the base type of the prefix, and EM is the encoding method
 585
 586    --  For decimal types with size <= Integer'Size, typ'Value (X)
 587    --  expands into
 588
 589    --    btyp?(Value_Decimal (X, typ'Scale));
 590
 591    --  For all other decimal types, typ'Value (X) expands into
 592
 593    --    btyp?(Value_Long_Long_Decimal (X, typ'Scale))
 594
 595    --  For enumeration types other than those derived from types Boolean,
 596    --  Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
 597
 598    --    Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
 599
 600    --  where typS and typI and the Lit_Strings and Lit_Indexes entities
 601    --  from T's root type entity, and Num is Enum'Pos (Enum'Last). The
 602    --  Value_Enumeration_NN function will search the tables looking for
 603    --  X and return the position number in the table if found which is
 604    --  used to provide the result of 'Value (using Enum'Val). If the
 605    --  value is not found Constraint_Error is raised. The suffix _NN
 606    --  depends on the element type of typI.
 607
 608    procedure Expand_Value_Attribute (N : Node_Id) is
 609       Loc   : constant Source_Ptr := Sloc (N);
 610       Typ   : constant Entity_Id  := Etype (N);
 611       Btyp  : constant Entity_Id  := Base_Type (Typ);
 612       Rtyp  : constant Entity_Id  := Root_Type (Typ);
 613       Exprs : constant List_Id    := Expressions (N);
 614       Vid   : RE_Id;
 615       Args  : List_Id;
 616       Func  : RE_Id;
 617       Ttyp  : Entity_Id;
 618
 619    begin
 620       Args := Exprs;
 621
 622       if Rtyp = Standard_Character then
 623          Vid := RE_Value_Character;
 624
 625       elsif Rtyp = Standard_Boolean then
 626          Vid := RE_Value_Boolean;
 627
 628       elsif Rtyp = Standard_Wide_Character then
 629          Vid := RE_Value_Wide_Character;
 630
 631          Append_To (Args,
 632            Make_Integer_Literal (Loc,
 633              Intval => Int (Wide_Character_Encoding_Method)));
 634
 635       elsif Rtyp = Standard_Wide_Wide_Character then
 636          Vid := RE_Value_Wide_Wide_Character;
 637
 638          Append_To (Args,
 639            Make_Integer_Literal (Loc,
 640              Intval => Int (Wide_Character_Encoding_Method)));
 641
 642       elsif     Rtyp = Base_Type (Standard_Short_Short_Integer)
 643         or else Rtyp = Base_Type (Standard_Short_Integer)
 644         or else Rtyp = Base_Type (Standard_Integer)
 645       then
 646          Vid := RE_Value_Integer;
 647
 648       elsif Is_Signed_Integer_Type (Rtyp) then
 649          Vid := RE_Value_Long_Long_Integer;
 650
 651       elsif Is_Modular_Integer_Type (Rtyp) then
 652          if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
 653             Vid := RE_Value_Unsigned;
 654          else
 655             Vid := RE_Value_Long_Long_Unsigned;
 656          end if;
 657
 658       elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
 659          if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
 660             Vid := RE_Value_Decimal;
 661          else
 662             Vid := RE_Value_Long_Long_Decimal;
 663          end if;
 664
 665          Append_To (Args,
 666            Make_Attribute_Reference (Loc,
 667              Prefix => New_Occurrence_Of (Typ, Loc),
 668              Attribute_Name => Name_Scale));
 669
 670          Rewrite (N,
 671            OK_Convert_To (Btyp,
 672              Make_Function_Call (Loc,
 673                Name => New_Occurrence_Of (RTE (Vid), Loc),
 674                Parameter_Associations => Args)));
 675
 676          Set_Etype (N, Btyp);
 677          Analyze_And_Resolve (N, Btyp);
 678          return;
 679
 680       elsif Is_Real_Type (Rtyp) then
 681          Vid := RE_Value_Real;
 682
 683       --  Only other possibility is user defined enumeration type
 684
 685       else
 686          pragma Assert (Is_Enumeration_Type (Rtyp));
 687
 688          --  Case of pragma Discard_Names, transform the Value
 689          --  attribute to Btyp'Val (Long_Long_Integer'Value (Args))
 690
 691          if Discard_Names (First_Subtype (Typ))
 692            or else No (Lit_Strings (Rtyp))
 693          then
 694             Rewrite (N,
 695               Make_Attribute_Reference (Loc,
 696                 Prefix => New_Occurrence_Of (Btyp, Loc),
 697                 Attribute_Name => Name_Val,
 698                 Expressions => New_List (
 699                   Make_Attribute_Reference (Loc,
 700                     Prefix =>
 701                       New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
 702                     Attribute_Name => Name_Value,
 703                     Expressions => Args))));
 704
 705             Analyze_And_Resolve (N, Btyp);
 706
 707          --  Here for normal case where we have enumeration tables, this
 708          --  is where we build
 709
 710          --    T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
 711
 712          else
 713             Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
 714
 715             if Ttyp = Standard_Integer_8 then
 716                Func := RE_Value_Enumeration_8;
 717             elsif Ttyp = Standard_Integer_16 then
 718                Func := RE_Value_Enumeration_16;
 719             else
 720                Func := RE_Value_Enumeration_32;
 721             end if;
 722
 723             Prepend_To (Args,
 724               Make_Attribute_Reference (Loc,
 725                 Prefix => New_Occurrence_Of (Rtyp, Loc),
 726                 Attribute_Name => Name_Pos,
 727                 Expressions => New_List (
 728                   Make_Attribute_Reference (Loc,
 729                     Prefix => New_Occurrence_Of (Rtyp, Loc),
 730                     Attribute_Name => Name_Last))));
 731
 732             Prepend_To (Args,
 733               Make_Attribute_Reference (Loc,
 734                 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
 735                 Attribute_Name => Name_Address));
 736
 737             Prepend_To (Args,
 738               New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
 739
 740             Rewrite (N,
 741               Make_Attribute_Reference (Loc,
 742                 Prefix => New_Occurrence_Of (Typ, Loc),
 743                 Attribute_Name => Name_Val,
 744                 Expressions => New_List (
 745                   Make_Function_Call (Loc,
 746                     Name =>
 747                       New_Occurrence_Of (RTE (Func), Loc),
 748                     Parameter_Associations => Args))));
 749
 750             Analyze_And_Resolve (N, Btyp);
 751          end if;
 752
 753          return;
 754       end if;
 755
 756       --  Fall through for all cases except user defined enumeration type
 757       --  and decimal types, with Vid set to the Id of the entity for the
 758       --  Value routine and Args set to the list of parameters for the call.
 759
 760       --  Compiling package Ada.Tags under No_Run_Time_Mode we disable the
 761       --  expansion of the attribute into the function call statement to avoid
 762       --  generating spurious errors caused by the use of Integer_Address'Value
 763       --  in our implementation of Ada.Tags.Internal_Tag
 764
 765       --  Seems like a bit of a odd approach, there should be a better way ???
 766
 767       --  There is a better way, test RTE_Available ???
 768
 769       if No_Run_Time_Mode
 770         and then Rtyp = RTE (RE_Integer_Address)
 771         and then RTU_Loaded (Ada_Tags)
 772         and then Cunit_Entity (Current_Sem_Unit)
 773                    = Body_Entity (RTU_Entity (Ada_Tags))
 774       then
 775          Rewrite (N,
 776            Unchecked_Convert_To (Rtyp,
 777              Make_Integer_Literal (Loc, Uint_0)));
 778       else
 779          Rewrite (N,
 780            Convert_To (Btyp,
 781              Make_Function_Call (Loc,
 782                Name => New_Occurrence_Of (RTE (Vid), Loc),
 783                Parameter_Associations => Args)));
 784       end if;
 785
 786       Analyze_And_Resolve (N, Btyp);
 787    end Expand_Value_Attribute;
 788
 789    ---------------------------------
 790    -- Expand_Wide_Image_Attribute --
 791    ---------------------------------
 792
 793    --  We expand typ'Wide_Image (X) as follows. First we insert this code:
 794
 795    --    Rnn : Wide_String (1 .. rt'Wide_Width);
 796    --    Lnn : Natural;
 797    --    String_To_Wide_String
 798    --      (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
 799
 800    --  where rt is the root type of the prefix type
 801
 802    --  Now we replace the Wide_Image reference by
 803
 804    --    Rnn (1 .. Lnn)
 805
 806    --  This works in all cases because String_To_Wide_String converts any
 807    --  wide character escape sequences resulting from the Image call to the
 808    --  proper Wide_Character equivalent
 809
 810    --  not quite right for typ = Wide_Character ???
 811
 812    procedure Expand_Wide_Image_Attribute (N : Node_Id) is
 813       Loc  : constant Source_Ptr := Sloc (N);
 814       Pref : constant Entity_Id  := Prefix (N);
 815       Rnn  : constant Entity_Id  := Make_Temporary (Loc, 'S');
 816       Lnn  : constant Entity_Id  := Make_Temporary (Loc, 'P');
 817       Rtyp : Entity_Id;
 818
 819    begin
 820       if Is_Object_Image (Pref) then
 821          Rewrite_Object_Image (N, Pref, Name_Wide_Image, Standard_Wide_String);
 822          return;
 823       end if;
 824
 825       Rtyp := Root_Type (Entity (Pref));
 826
 827       Insert_Actions (N, New_List (
 828
 829          --  Rnn : Wide_String (1 .. base_typ'Width);
 830
 831          Make_Object_Declaration (Loc,
 832             Defining_Identifier => Rnn,
 833             Object_Definition   =>
 834               Make_Subtype_Indication (Loc,
 835                 Subtype_Mark =>
 836                   New_Occurrence_Of (Standard_Wide_String, Loc),
 837                 Constraint   =>
 838                   Make_Index_Or_Discriminant_Constraint (Loc,
 839                     Constraints => New_List (
 840                       Make_Range (Loc,
 841                         Low_Bound  => Make_Integer_Literal (Loc, 1),
 842                         High_Bound =>
 843                           Make_Attribute_Reference (Loc,
 844                             Prefix         => New_Occurrence_Of (Rtyp, Loc),
 845                             Attribute_Name => Name_Wide_Width)))))),
 846
 847          --  Lnn : Natural;
 848
 849          Make_Object_Declaration (Loc,
 850            Defining_Identifier => Lnn,
 851            Object_Definition   => New_Occurrence_Of (Standard_Natural, Loc)),
 852
 853          --    String_To_Wide_String
 854          --      (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
 855
 856          Make_Procedure_Call_Statement (Loc,
 857            Name =>
 858              New_Occurrence_Of (RTE (RE_String_To_Wide_String), Loc),
 859
 860            Parameter_Associations => New_List (
 861              Make_Attribute_Reference (Loc,
 862                Prefix         => Prefix (N),
 863                Attribute_Name => Name_Image,
 864                Expressions    => Expressions (N)),
 865              New_Occurrence_Of (Rnn, Loc),
 866              New_Occurrence_Of (Lnn, Loc),
 867              Make_Integer_Literal (Loc,
 868                Intval => Int (Wide_Character_Encoding_Method))))),
 869
 870          --  Suppress checks because we know everything is properly in range
 871
 872          Suppress => All_Checks);
 873
 874       --  Final step is to rewrite the expression as a slice and analyze,
 875       --  again with no checks, since we are sure that everything is OK.
 876
 877       Rewrite (N,
 878         Make_Slice (Loc,
 879           Prefix         => New_Occurrence_Of (Rnn, Loc),
 880           Discrete_Range =>
 881             Make_Range (Loc,
 882               Low_Bound  => Make_Integer_Literal (Loc, 1),
 883               High_Bound => New_Occurrence_Of (Lnn, Loc))));
 884
 885       Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks);
 886    end Expand_Wide_Image_Attribute;
 887
 888    --------------------------------------
 889    -- Expand_Wide_Wide_Image_Attribute --
 890    --------------------------------------
 891
 892    --  We expand typ'Wide_Wide_Image (X) as follows. First we insert this code:
 893
 894    --    Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
 895    --    Lnn : Natural;
 896    --    String_To_Wide_Wide_String
 897    --      (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
 898
 899    --  where rt is the root type of the prefix type
 900
 901    --  Now we replace the Wide_Wide_Image reference by
 902
 903    --    Rnn (1 .. Lnn)
 904
 905    --  This works in all cases because String_To_Wide_Wide_String converts any
 906    --  wide character escape sequences resulting from the Image call to the
 907    --  proper Wide_Wide_Character equivalent
 908
 909    --  not quite right for typ = Wide_Wide_Character ???
 910
 911    procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is
 912       Loc  : constant Source_Ptr := Sloc (N);
 913       Pref : constant Entity_Id  := Prefix (N);
 914       Rnn  : constant Entity_Id  := Make_Temporary (Loc, 'S');
 915       Lnn  : constant Entity_Id  := Make_Temporary (Loc, 'P');
 916       Rtyp : Entity_Id;
 917
 918    begin
 919       if Is_Object_Image (Pref) then
 920          Rewrite_Object_Image
 921            (N, Pref, Name_Wide_Wide_Image, Standard_Wide_Wide_String);
 922          return;
 923       end if;
 924
 925       Rtyp := Root_Type (Entity (Pref));
 926
 927       Insert_Actions (N, New_List (
 928
 929          --  Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
 930
 931          Make_Object_Declaration (Loc,
 932             Defining_Identifier => Rnn,
 933             Object_Definition   =>
 934               Make_Subtype_Indication (Loc,
 935                 Subtype_Mark =>
 936                   New_Occurrence_Of (Standard_Wide_Wide_String, Loc),
 937                 Constraint   =>
 938                   Make_Index_Or_Discriminant_Constraint (Loc,
 939                     Constraints => New_List (
 940                       Make_Range (Loc,
 941                         Low_Bound  => Make_Integer_Literal (Loc, 1),
 942                         High_Bound =>
 943                           Make_Attribute_Reference (Loc,
 944                             Prefix         => New_Occurrence_Of (Rtyp, Loc),
 945                             Attribute_Name => Name_Wide_Wide_Width)))))),
 946
 947          --  Lnn : Natural;
 948
 949          Make_Object_Declaration (Loc,
 950            Defining_Identifier => Lnn,
 951            Object_Definition   => New_Occurrence_Of (Standard_Natural, Loc)),
 952
 953          --    String_To_Wide_Wide_String
 954          --      (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
 955
 956          Make_Procedure_Call_Statement (Loc,
 957            Name =>
 958              New_Occurrence_Of (RTE (RE_String_To_Wide_Wide_String), Loc),
 959
 960            Parameter_Associations => New_List (
 961              Make_Attribute_Reference (Loc,
 962                Prefix         => Prefix (N),
 963                Attribute_Name => Name_Image,
 964                Expressions    => Expressions (N)),
 965              New_Occurrence_Of (Rnn, Loc),
 966              New_Occurrence_Of (Lnn, Loc),
 967              Make_Integer_Literal (Loc,
 968                Intval => Int (Wide_Character_Encoding_Method))))),
 969
 970          --  Suppress checks because we know everything is properly in range
 971
 972          Suppress => All_Checks);
 973
 974       --  Final step is to rewrite the expression as a slice and analyze,
 975       --  again with no checks, since we are sure that everything is OK.
 976
 977       Rewrite (N,
 978         Make_Slice (Loc,
 979           Prefix         => New_Occurrence_Of (Rnn, Loc),
 980           Discrete_Range =>
 981             Make_Range (Loc,
 982               Low_Bound  => Make_Integer_Literal (Loc, 1),
 983               High_Bound => New_Occurrence_Of (Lnn, Loc))));
 984
 985       Analyze_And_Resolve
 986         (N, Standard_Wide_Wide_String, Suppress => All_Checks);
 987    end Expand_Wide_Wide_Image_Attribute;
 988
 989    ----------------------------
 990    -- Expand_Width_Attribute --
 991    ----------------------------
 992
 993    --  The processing here also handles the case of Wide_[Wide_]Width. With the
 994    --  exceptions noted, the processing is identical
 995
 996    --  For scalar types derived from Boolean, character and integer types
 997    --  in package Standard. Note that the Width attribute is computed at
 998    --  compile time for all cases except those involving non-static sub-
 999    --  types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
1000
1001    --    Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
1002
1003    --  where
1004
1005    --    For types whose root type is Character
1006    --      xx = Width_Character
1007    --      yy = Character
1008
1009    --    For types whose root type is Wide_Character
1010    --      xx = Wide_Width_Character
1011    --      yy = Character
1012
1013    --    For types whose root type is Wide_Wide_Character
1014    --      xx = Wide_Wide_Width_Character
1015    --      yy = Character
1016
1017    --    For types whose root type is Boolean
1018    --      xx = Width_Boolean
1019    --      yy = Boolean
1020
1021    --    For signed integer types
1022    --      xx = Width_Long_Long_Integer
1023    --      yy = Long_Long_Integer
1024
1025    --    For modular integer types
1026    --      xx = Width_Long_Long_Unsigned
1027    --      yy = Long_Long_Unsigned
1028
1029    --  For types derived from Wide_Character, typ'Width expands into
1030
1031    --    Result_Type (Width_Wide_Character (
1032    --      Wide_Character (typ'First),
1033    --      Wide_Character (typ'Last),
1034
1035    --  and typ'Wide_Width expands into:
1036
1037    --    Result_Type (Wide_Width_Wide_Character (
1038    --      Wide_Character (typ'First),
1039    --      Wide_Character (typ'Last));
1040
1041    --  and typ'Wide_Wide_Width expands into
1042
1043    --    Result_Type (Wide_Wide_Width_Wide_Character (
1044    --      Wide_Character (typ'First),
1045    --      Wide_Character (typ'Last));
1046
1047    --  For types derived from Wide_Wide_Character, typ'Width expands into
1048
1049    --    Result_Type (Width_Wide_Wide_Character (
1050    --      Wide_Wide_Character (typ'First),
1051    --      Wide_Wide_Character (typ'Last),
1052
1053    --  and typ'Wide_Width expands into:
1054
1055    --    Result_Type (Wide_Width_Wide_Wide_Character (
1056    --      Wide_Wide_Character (typ'First),
1057    --      Wide_Wide_Character (typ'Last));
1058
1059    --  and typ'Wide_Wide_Width expands into
1060
1061    --    Result_Type (Wide_Wide_Width_Wide_Wide_Char (
1062    --      Wide_Wide_Character (typ'First),
1063    --      Wide_Wide_Character (typ'Last));
1064
1065    --  For real types, typ'Width and typ'Wide_[Wide_]Width expand into
1066
1067    --    if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
1068
1069    --  where btyp is the base type. This looks recursive but it isn't
1070    --  because the base type is always static, and hence the expression
1071    --  in the else is reduced to an integer literal.
1072
1073    --  For user defined enumeration types, typ'Width expands into
1074
1075    --    Result_Type (Width_Enumeration_NN
1076    --                  (typS,
1077    --                   typI'Address,
1078    --                   typ'Pos (typ'First),
1079    --                   typ'Pos (Typ'Last)));
1080
1081    --  and typ'Wide_Width expands into:
1082
1083    --    Result_Type (Wide_Width_Enumeration_NN
1084    --                  (typS,
1085    --                   typI,
1086    --                   typ'Pos (typ'First),
1087    --                   typ'Pos (Typ'Last))
1088    --                   Wide_Character_Encoding_Method);
1089
1090    --  and typ'Wide_Wide_Width expands into:
1091
1092    --    Result_Type (Wide_Wide_Width_Enumeration_NN
1093    --                  (typS,
1094    --                   typI,
1095    --                   typ'Pos (typ'First),
1096    --                   typ'Pos (Typ'Last))
1097    --                   Wide_Character_Encoding_Method);
1098
1099    --  where typS and typI are the enumeration image strings and indexes
1100    --  table, as described in Build_Enumeration_Image_Tables. NN is 8/16/32
1101    --  for depending on the element type for typI.
1102
1103    --  Finally if Discard_Names is in effect for an enumeration type, then
1104    --  a special if expression is built that yields the space needed for the
1105    --  decimal representation of the largest pos value in the subtype. See
1106    --  code below for details.
1107
1108    procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is
1109       Loc     : constant Source_Ptr := Sloc (N);
1110       Typ     : constant Entity_Id  := Etype (N);
1111       Pref    : constant Node_Id    := Prefix (N);
1112       Ptyp    : constant Entity_Id  := Etype (Pref);
1113       Rtyp    : constant Entity_Id  := Root_Type (Ptyp);
1114       Arglist : List_Id;
1115       Ttyp    : Entity_Id;
1116       XX      : RE_Id;
1117       YY      : Entity_Id;
1118
1119    begin
1120       --  Types derived from Standard.Boolean
1121
1122       if Rtyp = Standard_Boolean then
1123          XX := RE_Width_Boolean;
1124          YY := Rtyp;
1125
1126       --  Types derived from Standard.Character
1127
1128       elsif Rtyp = Standard_Character then
1129          case Attr is
1130             when Normal    => XX := RE_Width_Character;
1131             when Wide      => XX := RE_Wide_Width_Character;
1132             when Wide_Wide => XX := RE_Wide_Wide_Width_Character;
1133          end case;
1134
1135          YY := Rtyp;
1136
1137       --  Types derived from Standard.Wide_Character
1138
1139       elsif Rtyp = Standard_Wide_Character then
1140          case Attr is
1141             when Normal    => XX := RE_Width_Wide_Character;
1142             when Wide      => XX := RE_Wide_Width_Wide_Character;
1143             when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character;
1144          end case;
1145
1146          YY := Rtyp;
1147
1148       --  Types derived from Standard.Wide_Wide_Character
1149
1150       elsif Rtyp = Standard_Wide_Wide_Character then
1151          case Attr is
1152             when Normal    => XX := RE_Width_Wide_Wide_Character;
1153             when Wide      => XX := RE_Wide_Width_Wide_Wide_Character;
1154             when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char;
1155          end case;
1156
1157          YY := Rtyp;
1158
1159       --  Signed integer types
1160
1161       elsif Is_Signed_Integer_Type (Rtyp) then
1162          XX := RE_Width_Long_Long_Integer;
1163          YY := Standard_Long_Long_Integer;
1164
1165       --  Modular integer types
1166
1167       elsif Is_Modular_Integer_Type (Rtyp) then
1168          XX := RE_Width_Long_Long_Unsigned;
1169          YY := RTE (RE_Long_Long_Unsigned);
1170
1171       --  Real types
1172
1173       elsif Is_Real_Type (Rtyp) then
1174          Rewrite (N,
1175            Make_If_Expression (Loc,
1176              Expressions => New_List (
1177
1178                Make_Op_Gt (Loc,
1179                  Left_Opnd =>
1180                    Make_Attribute_Reference (Loc,
1181                      Prefix => New_Occurrence_Of (Ptyp, Loc),
1182                      Attribute_Name => Name_First),
1183
1184                  Right_Opnd =>
1185                    Make_Attribute_Reference (Loc,
1186                      Prefix => New_Occurrence_Of (Ptyp, Loc),
1187                      Attribute_Name => Name_Last)),
1188
1189                Make_Integer_Literal (Loc, 0),
1190
1191                Make_Attribute_Reference (Loc,
1192                  Prefix => New_Occurrence_Of (Base_Type (Ptyp), Loc),
1193                  Attribute_Name => Name_Width))));
1194
1195          Analyze_And_Resolve (N, Typ);
1196          return;
1197
1198       --  User defined enumeration types
1199
1200       else
1201          pragma Assert (Is_Enumeration_Type (Rtyp));
1202
1203          --  Whenever pragma Discard_Names is in effect, the value we need
1204          --  is the value needed to accommodate the largest integer pos value
1205          --  in the range of the subtype + 1 for the space at the start. We
1206          --  build:
1207
1208          --     Tnn : constant Integer := Rtyp'Pos (Ptyp'Last)
1209
1210          --  and replace the expression by
1211
1212          --     (if Ptyp'Range_Length = 0 then 0
1213          --      else (if Tnn < 10 then 2
1214          --            else (if Tnn < 100 then 3
1215          --                  ...
1216          --                      else n)))...
1217
1218          --  where n is equal to Rtyp'Pos (Ptyp'Last) + 1
1219
1220          --  Note: The above processing is in accordance with the intent of
1221          --  the RM, which is that Width should be related to the impl-defined
1222          --  behavior of Image. It is not clear what this means if Image is
1223          --  not defined (as in the configurable run-time case for GNAT) and
1224          --  gives an error at compile time.
1225
1226          --  We choose in this case to just go ahead and implement Width the
1227          --  same way, returning what Image would have returned if it has been
1228          --  available in the configurable run-time library.
1229
1230          if Discard_Names (Rtyp) then
1231             declare
1232                Tnn   : constant Entity_Id := Make_Temporary (Loc, 'T');
1233                Cexpr : Node_Id;
1234                P     : Int;
1235                M     : Int;
1236                K     : Int;
1237
1238             begin
1239                Insert_Action (N,
1240                  Make_Object_Declaration (Loc,
1241                    Defining_Identifier => Tnn,
1242                    Constant_Present    => True,
1243                    Object_Definition   =>
1244                      New_Occurrence_Of (Standard_Integer, Loc),
1245                    Expression =>
1246                      Make_Attribute_Reference (Loc,
1247                        Prefix         => New_Occurrence_Of (Rtyp, Loc),
1248                        Attribute_Name => Name_Pos,
1249                        Expressions    => New_List (
1250                          Convert_To (Rtyp,
1251                            Make_Attribute_Reference (Loc,
1252                              Prefix         => New_Occurrence_Of (Ptyp, Loc),
1253                              Attribute_Name => Name_Last))))));
1254
1255                --  OK, now we need to build the if expression. First get the
1256                --  value of M, the largest possible value needed.
1257
1258                P := UI_To_Int
1259                       (Enumeration_Pos (Entity (Type_High_Bound (Rtyp))));
1260
1261                K := 1;
1262                M := 1;
1263                while M < P loop
1264                   M := M * 10;
1265                   K := K + 1;
1266                end loop;
1267
1268                --  Build inner else
1269
1270                Cexpr := Make_Integer_Literal (Loc, K);
1271
1272                --  Wrap in inner if's until counted down to 2
1273
1274                while K > 2 loop
1275                   M := M / 10;
1276                   K := K - 1;
1277
1278                   Cexpr :=
1279                     Make_If_Expression (Loc,
1280                       Expressions => New_List (
1281                         Make_Op_Lt (Loc,
1282                           Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
1283                           Right_Opnd => Make_Integer_Literal (Loc, M)),
1284                         Make_Integer_Literal (Loc, K),
1285                         Cexpr));
1286                end loop;
1287
1288                --  Add initial comparison for null range and we are done, so
1289                --  rewrite the attribute occurrence with this expression.
1290
1291                Rewrite (N,
1292                  Convert_To (Typ,
1293                    Make_If_Expression (Loc,
1294                      Expressions => New_List (
1295                        Make_Op_Eq (Loc,
1296                          Left_Opnd  =>
1297                            Make_Attribute_Reference (Loc,
1298                              Prefix         => New_Occurrence_Of (Ptyp, Loc),
1299                              Attribute_Name => Name_Range_Length),
1300                          Right_Opnd => Make_Integer_Literal (Loc, 0)),
1301                        Make_Integer_Literal (Loc, 0),
1302                        Cexpr))));
1303
1304                Analyze_And_Resolve (N, Typ);
1305                return;
1306             end;
1307          end if;
1308
1309          --  Normal case, not Discard_Names
1310
1311          Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1312
1313          case Attr is
1314             when Normal =>
1315                if Ttyp = Standard_Integer_8 then
1316                   XX := RE_Width_Enumeration_8;
1317                elsif Ttyp = Standard_Integer_16 then
1318                   XX := RE_Width_Enumeration_16;
1319                else
1320                   XX := RE_Width_Enumeration_32;
1321                end if;
1322
1323             when Wide =>
1324                if Ttyp = Standard_Integer_8 then
1325                   XX := RE_Wide_Width_Enumeration_8;
1326                elsif Ttyp = Standard_Integer_16 then
1327                   XX := RE_Wide_Width_Enumeration_16;
1328                else
1329                   XX := RE_Wide_Width_Enumeration_32;
1330                end if;
1331
1332             when Wide_Wide =>
1333                if Ttyp = Standard_Integer_8 then
1334                   XX := RE_Wide_Wide_Width_Enumeration_8;
1335                elsif Ttyp = Standard_Integer_16 then
1336                   XX := RE_Wide_Wide_Width_Enumeration_16;
1337                else
1338                   XX := RE_Wide_Wide_Width_Enumeration_32;
1339                end if;
1340          end case;
1341
1342          Arglist :=
1343            New_List (
1344              New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
1345
1346              Make_Attribute_Reference (Loc,
1347                Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1348                Attribute_Name => Name_Address),
1349
1350              Make_Attribute_Reference (Loc,
1351                Prefix => New_Occurrence_Of (Ptyp, Loc),
1352                Attribute_Name => Name_Pos,
1353
1354                Expressions => New_List (
1355                  Make_Attribute_Reference (Loc,
1356                    Prefix => New_Occurrence_Of (Ptyp, Loc),
1357                    Attribute_Name => Name_First))),
1358
1359              Make_Attribute_Reference (Loc,
1360                Prefix => New_Occurrence_Of (Ptyp, Loc),
1361                Attribute_Name => Name_Pos,
1362
1363                Expressions => New_List (
1364                  Make_Attribute_Reference (Loc,
1365                    Prefix => New_Occurrence_Of (Ptyp, Loc),
1366                    Attribute_Name => Name_Last))));
1367
1368          Rewrite (N,
1369            Convert_To (Typ,
1370              Make_Function_Call (Loc,
1371                Name => New_Occurrence_Of (RTE (XX), Loc),
1372                Parameter_Associations => Arglist)));
1373
1374          Analyze_And_Resolve (N, Typ);
1375          return;
1376       end if;
1377
1378       --  If we fall through XX and YY are set
1379
1380       Arglist := New_List (
1381         Convert_To (YY,
1382           Make_Attribute_Reference (Loc,
1383             Prefix => New_Occurrence_Of (Ptyp, Loc),
1384             Attribute_Name => Name_First)),
1385
1386         Convert_To (YY,
1387           Make_Attribute_Reference (Loc,
1388             Prefix => New_Occurrence_Of (Ptyp, Loc),
1389             Attribute_Name => Name_Last)));
1390
1391       Rewrite (N,
1392         Convert_To (Typ,
1393           Make_Function_Call (Loc,
1394             Name => New_Occurrence_Of (RTE (XX), Loc),
1395             Parameter_Associations => Arglist)));
1396
1397       Analyze_And_Resolve (N, Typ);
1398    end Expand_Width_Attribute;
1399
1400    -----------------------
1401    -- Has_Decimal_Small --
1402    -----------------------
1403
1404    function Has_Decimal_Small (E : Entity_Id) return Boolean is
1405    begin
1406       return Is_Decimal_Fixed_Point_Type (E)
1407         or else
1408           (Is_Ordinary_Fixed_Point_Type (E)
1409              and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1);
1410    end Has_Decimal_Small;
1411
1412    --------------------------
1413    -- Rewrite_Object_Image --
1414    --------------------------
1415
1416    procedure Rewrite_Object_Image
1417      (N         : Node_Id;
1418       Pref      : Entity_Id;
1419       Attr_Name : Name_Id;
1420       Str_Typ   : Entity_Id)
1421    is
1422    begin
1423       Rewrite (N,
1424         Make_Attribute_Reference (Sloc (N),
1425           Prefix         => New_Occurrence_Of (Etype (Pref), Sloc (N)),
1426           Attribute_Name => Attr_Name,
1427           Expressions    => New_List (Relocate_Node (Pref))));
1428
1429       Analyze_And_Resolve (N, Str_Typ);
1430    end Rewrite_Object_Image;
1431 end Exp_Imgv;