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