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-2004 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Casing;   use Casing;
  29 with Checks;   use Checks;
  30 with Einfo;    use Einfo;
  31 with Exp_Util; use Exp_Util;
  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_Res;  use Sem_Res;
  38 with Sinfo;    use Sinfo;
  39 with Snames;   use Snames;
  40 with Stand;    use Stand;
  41 with Stringt;  use Stringt;
  42 with Tbuild;   use Tbuild;
  43 with Ttypes;   use Ttypes;
  44 with Uintp;    use Uintp;
  45
  46 package body Exp_Imgv is
  47
  48    ------------------------------------
  49    -- Build_Enumeration_Image_Tables --
  50    ------------------------------------
  51
  52    procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is
  53       Loc  : constant Source_Ptr := Sloc (E);
  54       Str  : String_Id;
  55       Ind  : List_Id;
  56       Lit  : Entity_Id;
  57       Nlit : Nat;
  58       Len  : Nat;
  59       Estr : Entity_Id;
  60       Eind : Entity_Id;
  61       Ityp : Node_Id;
  62
  63    begin
  64       --  Nothing to do for other than a root enumeration type
  65
  66       if E /= Root_Type (E) then
  67          return;
  68
  69       --  Nothing to do if pragma Discard_Names applies
  70
  71       elsif Discard_Names (E) then
  72          return;
  73       end if;
  74
  75       --  Otherwise tables need constructing
  76
  77       Start_String;
  78       Ind := New_List;
  79       Lit := First_Literal (E);
  80       Len := 1;
  81       Nlit := 0;
  82
  83       loop
  84          Append_To (Ind,
  85            Make_Integer_Literal (Loc, UI_From_Int (Len)));
  86
  87          exit when No (Lit);
  88          Nlit := Nlit + 1;
  89
  90          Get_Unqualified_Decoded_Name_String (Chars (Lit));
  91
  92          if Name_Buffer (1) /= ''' then
  93             Set_Casing (All_Upper_Case);
  94          end if;
  95
  96          Store_String_Chars (Name_Buffer (1 .. Name_Len));
  97          Len := Len + Int (Name_Len);
  98          Next_Literal (Lit);
  99       end loop;
 100
 101       if Len < Int (2 ** (8 - 1)) then
 102          Ityp := Standard_Integer_8;
 103       elsif Len < Int (2 ** (16 - 1)) then
 104          Ityp := Standard_Integer_16;
 105       else
 106          Ityp := Standard_Integer_32;
 107       end if;
 108
 109       Str := End_String;
 110
 111       Estr :=
 112         Make_Defining_Identifier (Loc,
 113           Chars => New_External_Name (Chars (E), 'S'));
 114
 115       Eind :=
 116         Make_Defining_Identifier (Loc,
 117           Chars => New_External_Name (Chars (E), 'N'));
 118
 119       Set_Lit_Strings (E, Estr);
 120       Set_Lit_Indexes (E, Eind);
 121
 122       Insert_Actions (N,
 123         New_List (
 124           Make_Object_Declaration (Loc,
 125             Defining_Identifier => Estr,
 126             Constant_Present    => True,
 127             Object_Definition   =>
 128               New_Occurrence_Of (Standard_String, Loc),
 129             Expression          =>
 130               Make_String_Literal (Loc,
 131                 Strval => Str)),
 132
 133           Make_Object_Declaration (Loc,
 134             Defining_Identifier => Eind,
 135             Constant_Present    => True,
 136
 137             Object_Definition =>
 138               Make_Constrained_Array_Definition (Loc,
 139                 Discrete_Subtype_Definitions => New_List (
 140                   Make_Range (Loc,
 141                     Low_Bound  => Make_Integer_Literal (Loc, 0),
 142                     High_Bound => Make_Integer_Literal (Loc, Nlit))),
 143                 Component_Definition =>
 144                   Make_Component_Definition (Loc,
 145                     Aliased_Present    => False,
 146                     Subtype_Indication => New_Occurrence_Of (Ityp, Loc))),
 147
 148             Expression          =>
 149               Make_Aggregate (Loc,
 150                 Expressions => Ind))),
 151         Suppress => All_Checks);
 152
 153    end Build_Enumeration_Image_Tables;
 154
 155    ----------------------------
 156    -- Expand_Image_Attribute --
 157    ----------------------------
 158
 159    --  For all non-enumeration types, and for enumeration types declared
 160    --  in packages Standard or System, typ'Image (Val) expands into:
 161
 162    --     Image_xx (tp (Expr) [, pm])
 163
 164    --  The name xx and type conversion tp (Expr) (called tv below) depend on
 165    --  the root type of Expr. The argument pm is an extra type dependent
 166    --  parameter only used in some cases as follows:
 167
 168    --    For types whose root type is Character
 169    --      xx = Character
 170    --      tv = Character (Expr)
 171
 172    --    For types whose root type is Boolean
 173    --      xx = Boolean
 174    --      tv = Boolean (Expr)
 175
 176    --    For signed integer types with size <= Integer'Size
 177    --      xx = Integer
 178    --      tv = Integer (Expr)
 179
 180    --    For other signed integer types
 181    --      xx = Long_Long_Integer
 182    --      tv = Long_Long_Integer (Expr)
 183
 184    --    For modular types with modulus <= System.Unsigned_Types.Unsigned
 185    --      xx = Unsigned
 186    --      tv = System.Unsigned_Types.Unsigned (Expr)
 187
 188    --    For other modular integer types
 189    --      xx = Long_Long_Unsigned
 190    --      tv = System.Unsigned_Types.Long_Long_Unsigned (Expr)
 191
 192    --    For types whose root type is Wide_Character
 193    --      xx = Wide_Character
 194    --      tv = Wide_Character (Expr)
 195    --      pm = Wide_Character_Encoding_Method
 196
 197    --    For floating-point types
 198    --      xx = Floating_Point
 199    --      tv = Long_Long_Float (Expr)
 200    --      pm = typ'Digits
 201
 202    --    For ordinary fixed-point types
 203    --      xx = Ordinary_Fixed_Point
 204    --      tv = Long_Long_Float (Expr)
 205    --      pm = typ'Aft
 206
 207    --    For decimal fixed-point types with size = Integer'Size
 208    --      xx = Decimal
 209    --      tv = Integer (Expr)
 210    --      pm = typ'Scale
 211
 212    --    For decimal fixed-point types with size > Integer'Size
 213    --      xx = Long_Long_Decimal
 214    --      tv = Long_Long_Integer (Expr)
 215    --      pm = typ'Scale
 216
 217    --    Note: for the decimal fixed-point type cases, the conversion is
 218    --    done literally without scaling (i.e. the actual expression that
 219    --    is generated is Image_xx (tp?(Expr) [, pm])
 220
 221    --  For enumeration types other than those declared packages Standard
 222    --  or System, typ'Image (X) expands into:
 223
 224    --    Image_Enumeration_NN (typ'Pos (X), typS, typI'Address)
 225
 226    --  where typS and typI are the entities constructed as described in
 227    --  the spec for the procedure Build_Enumeration_Image_Tables and NN
 228    --  is 32/16/8 depending on the element type of Lit_Indexes.
 229
 230    procedure Expand_Image_Attribute (N : Node_Id) is
 231       Loc      : constant Source_Ptr := Sloc (N);
 232       Exprs    : constant List_Id    := Expressions (N);
 233       Pref     : constant Node_Id    := Prefix (N);
 234       Ptyp     : constant Entity_Id  := Entity (Pref);
 235       Rtyp     : constant Entity_Id  := Root_Type (Ptyp);
 236       Expr     : constant Node_Id    := Relocate_Node (First (Exprs));
 237       Imid     : RE_Id;
 238       Tent     : Entity_Id;
 239       Arglist  : List_Id;
 240       Func     : RE_Id;
 241       Ttyp     : Entity_Id;
 242       Func_Ent : Entity_Id;
 243
 244    begin
 245       if Rtyp = Standard_Boolean then
 246          Imid := RE_Image_Boolean;
 247          Tent := Rtyp;
 248
 249       elsif Rtyp = Standard_Character then
 250          Imid := RE_Image_Character;
 251          Tent := Rtyp;
 252
 253       elsif Rtyp = Standard_Wide_Character then
 254          Imid := RE_Image_Wide_Character;
 255          Tent := Rtyp;
 256
 257       elsif Is_Signed_Integer_Type (Rtyp) then
 258          if Esize (Rtyp) <= Esize (Standard_Integer) then
 259             Imid := RE_Image_Integer;
 260             Tent := Standard_Integer;
 261          else
 262             Imid := RE_Image_Long_Long_Integer;
 263             Tent := Standard_Long_Long_Integer;
 264          end if;
 265
 266       elsif Is_Modular_Integer_Type (Rtyp) then
 267          if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
 268             Imid := RE_Image_Unsigned;
 269             Tent := RTE (RE_Unsigned);
 270          else
 271             Imid := RE_Image_Long_Long_Unsigned;
 272             Tent := RTE (RE_Long_Long_Unsigned);
 273          end if;
 274
 275       elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
 276          if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
 277             Imid := RE_Image_Decimal;
 278             Tent := Standard_Integer;
 279          else
 280             Imid := RE_Image_Long_Long_Decimal;
 281             Tent := Standard_Long_Long_Integer;
 282          end if;
 283
 284       elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
 285          Imid := RE_Image_Ordinary_Fixed_Point;
 286          Tent := Standard_Long_Long_Float;
 287
 288       elsif Is_Floating_Point_Type (Rtyp) then
 289          Imid := RE_Image_Floating_Point;
 290          Tent := Standard_Long_Long_Float;
 291
 292       --  Only other possibility is user defined enumeration type
 293
 294       else
 295          if Discard_Names (First_Subtype (Ptyp))
 296            or else No (Lit_Strings (Root_Type (Ptyp)))
 297          then
 298             --  When pragma Discard_Names applies to the first subtype,
 299             --  then build (Pref'Pos)'Img.
 300
 301             Rewrite (N,
 302               Make_Attribute_Reference (Loc,
 303                 Prefix =>
 304                    Make_Attribute_Reference (Loc,
 305                      Prefix         => Pref,
 306                      Attribute_Name => Name_Pos,
 307                      Expressions    => New_List (Expr)),
 308                 Attribute_Name =>
 309                   Name_Img));
 310             Analyze_And_Resolve (N, Standard_String);
 311
 312          else
 313             --  Here we get the Image of an enumeration type
 314
 315             Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
 316
 317             if Ttyp = Standard_Integer_8 then
 318                Func := RE_Image_Enumeration_8;
 319             elsif Ttyp = Standard_Integer_16  then
 320                Func := RE_Image_Enumeration_16;
 321             else
 322                Func := RE_Image_Enumeration_32;
 323             end if;
 324
 325             --  Apply a validity check, since it is a bit drastic to
 326             --  get a completely junk image value for an invalid value.
 327
 328             if not Expr_Known_Valid (Expr) then
 329                Insert_Valid_Check (Expr);
 330             end if;
 331
 332             Rewrite (N,
 333               Make_Function_Call (Loc,
 334                 Name => New_Occurrence_Of (RTE (Func), Loc),
 335                 Parameter_Associations => New_List (
 336                   Make_Attribute_Reference (Loc,
 337                     Attribute_Name => Name_Pos,
 338                     Prefix         => New_Occurrence_Of (Ptyp, Loc),
 339                     Expressions    => New_List (Expr)),
 340                   New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
 341                   Make_Attribute_Reference (Loc,
 342                     Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
 343                     Attribute_Name => Name_Address))));
 344
 345             Analyze_And_Resolve (N, Standard_String);
 346          end if;
 347
 348          return;
 349       end if;
 350
 351       --  If we fall through, we have one of the cases that is handled by
 352       --  calling one of the System.Img_xx routines and Imid is set to the
 353       --  RE_Id for the function to be called.
 354
 355       Func_Ent := RTE (Imid);
 356
 357       --  If the function entity is empty, that means we have a case in
 358       --  no run time mode where the operation is not allowed, and an
 359       --  appropriate diagnostic has already been issued.
 360
 361       if No (Func_Ent) then
 362          return;
 363       end if;
 364
 365       --  Otherwise prepare arguments for run-time call
 366
 367       Arglist := New_List (Convert_To (Tent, Relocate_Node (Expr)));
 368
 369       --  For floating-point types, append Digits argument
 370
 371       if Is_Floating_Point_Type (Rtyp) then
 372          Append_To (Arglist,
 373            Make_Attribute_Reference (Loc,
 374              Prefix         => New_Reference_To (Ptyp, Loc),
 375              Attribute_Name => Name_Digits));
 376
 377       --  For ordinary fixed-point types, append Aft parameter
 378
 379       elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
 380          Append_To (Arglist,
 381            Make_Attribute_Reference (Loc,
 382              Prefix         => New_Reference_To (Ptyp, Loc),
 383              Attribute_Name => Name_Aft));
 384
 385       --  For wide character, append encoding method
 386
 387       elsif Rtyp = Standard_Wide_Character then
 388          Append_To (Arglist,
 389            Make_Integer_Literal (Loc,
 390              Intval => Int (Wide_Character_Encoding_Method)));
 391
 392       --  For decimal, append Scale and also set to do literal conversion
 393
 394       elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
 395          Append_To (Arglist,
 396            Make_Attribute_Reference (Loc,
 397              Prefix => New_Reference_To (Ptyp, Loc),
 398              Attribute_Name => Name_Scale));
 399
 400          Set_Conversion_OK (First (Arglist));
 401          Set_Etype (First (Arglist), Tent);
 402       end if;
 403
 404       Rewrite (N,
 405         Make_Function_Call (Loc,
 406           Name => New_Reference_To (Func_Ent, Loc),
 407           Parameter_Associations => Arglist));
 408
 409       Analyze_And_Resolve (N, Standard_String);
 410    end Expand_Image_Attribute;
 411
 412    ----------------------------
 413    -- Expand_Value_Attribute --
 414    ----------------------------
 415
 416    --  For scalar types derived from Boolean, Character and integer types
 417    --  in package Standard, typ'Value (X) expands into:
 418
 419    --    btyp (Value_xx (X))
 420
 421    --  where btyp is he base type of the prefix, and
 422
 423    --    For types whose root type is Character
 424    --      xx = Character
 425
 426    --    For types whose root type is Boolean
 427    --      xx = Boolean
 428
 429    --    For signed integer types with size <= Integer'Size
 430    --      xx = Integer
 431
 432    --    For other signed integer types
 433    --      xx = Long_Long_Integer
 434
 435    --    For modular types with modulus <= System.Unsigned_Types.Unsigned
 436    --      xx = Unsigned
 437
 438    --    For other modular integer types
 439    --      xx = Long_Long_Unsigned
 440
 441    --    For floating-point types and ordinary fixed-point types
 442    --      xx = Real
 443
 444    --  For types derived from Wide_Character, typ'Value (X) expands into
 445
 446    --    Value_Wide_Character (X, Wide_Character_Encoding_Method)
 447
 448    --  For decimal types with size <= Integer'Size, typ'Value (X)
 449    --  expands into
 450
 451    --    btyp?(Value_Decimal (X, typ'Scale));
 452
 453    --  For all other decimal types, typ'Value (X) expands into
 454
 455    --    btyp?(Value_Long_Long_Decimal (X, typ'Scale))
 456
 457    --  For enumeration types other than those derived from types Boolean,
 458    --  Character, and Wide_Character in Standard, typ'Value (X) expands to:
 459
 460    --    Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
 461
 462    --  where typS and typI and the Lit_Strings and Lit_Indexes entities
 463    --  from T's root type entitym and Num is Enum'Pos (Enum'Last). The
 464    --  Value_Enumeration_NN function will search the tables looking for
 465    --  X and return the position number in the table if found which is
 466    --  used to provide the result of 'Value (using Enum'Val). If the
 467    --  value is not found Constraint_Error is raised. The suffix _NN
 468    --  depends on the element type of typI.
 469
 470    procedure Expand_Value_Attribute (N : Node_Id) is
 471       Loc   : constant Source_Ptr := Sloc (N);
 472       Typ   : constant Entity_Id  := Etype (N);
 473       Btyp  : constant Entity_Id  := Base_Type (Typ);
 474       Rtyp  : constant Entity_Id  := Root_Type (Typ);
 475       Exprs : constant List_Id    := Expressions (N);
 476       Vid   : RE_Id;
 477       Args  : List_Id;
 478       Func  : RE_Id;
 479       Ttyp  : Entity_Id;
 480
 481    begin
 482       Args := Exprs;
 483
 484       if Rtyp = Standard_Character then
 485          Vid := RE_Value_Character;
 486
 487       elsif Rtyp = Standard_Boolean then
 488          Vid := RE_Value_Boolean;
 489
 490       elsif Rtyp = Standard_Wide_Character then
 491          Vid := RE_Value_Wide_Character;
 492          Append_To (Args,
 493            Make_Integer_Literal (Loc,
 494              Intval => Int (Wide_Character_Encoding_Method)));
 495
 496       elsif     Rtyp = Base_Type (Standard_Short_Short_Integer)
 497         or else Rtyp = Base_Type (Standard_Short_Integer)
 498         or else Rtyp = Base_Type (Standard_Integer)
 499       then
 500          Vid := RE_Value_Integer;
 501
 502       elsif Is_Signed_Integer_Type (Rtyp) then
 503          Vid := RE_Value_Long_Long_Integer;
 504
 505       elsif Is_Modular_Integer_Type (Rtyp) then
 506          if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
 507             Vid := RE_Value_Unsigned;
 508          else
 509             Vid := RE_Value_Long_Long_Unsigned;
 510          end if;
 511
 512       elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
 513          if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
 514             Vid := RE_Value_Decimal;
 515          else
 516             Vid := RE_Value_Long_Long_Decimal;
 517          end if;
 518
 519          Append_To (Args,
 520            Make_Attribute_Reference (Loc,
 521              Prefix => New_Reference_To (Typ, Loc),
 522              Attribute_Name => Name_Scale));
 523
 524          Rewrite (N,
 525            OK_Convert_To (Btyp,
 526              Make_Function_Call (Loc,
 527                Name => New_Reference_To (RTE (Vid), Loc),
 528                Parameter_Associations => Args)));
 529
 530          Set_Etype (N, Btyp);
 531          Analyze_And_Resolve (N, Btyp);
 532          return;
 533
 534       elsif Is_Real_Type (Rtyp) then
 535          Vid := RE_Value_Real;
 536
 537       --  Only other possibility is user defined enumeration type
 538
 539       else
 540          pragma Assert (Is_Enumeration_Type (Rtyp));
 541
 542          --  Case of pragma Discard_Names, transform the Value
 543          --  attribute to Btyp'Val (Long_Long_Integer'Value (Args))
 544
 545          if Discard_Names (First_Subtype (Typ))
 546            or else No (Lit_Strings (Rtyp))
 547          then
 548             Rewrite (N,
 549               Make_Attribute_Reference (Loc,
 550                 Prefix => New_Reference_To (Btyp, Loc),
 551                 Attribute_Name => Name_Val,
 552                 Expressions => New_List (
 553                   Make_Attribute_Reference (Loc,
 554                     Prefix =>
 555                       New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
 556                     Attribute_Name => Name_Value,
 557                     Expressions => Args))));
 558
 559             Analyze_And_Resolve (N, Btyp);
 560
 561          --  Here for normal case where we have enumeration tables, this
 562          --  is where we build
 563
 564          --    T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
 565
 566          else
 567             Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
 568
 569             if Ttyp = Standard_Integer_8 then
 570                Func := RE_Value_Enumeration_8;
 571             elsif Ttyp = Standard_Integer_16  then
 572                Func := RE_Value_Enumeration_16;
 573             else
 574                Func := RE_Value_Enumeration_32;
 575             end if;
 576
 577             Prepend_To (Args,
 578               Make_Attribute_Reference (Loc,
 579                 Prefix => New_Occurrence_Of (Rtyp, Loc),
 580                 Attribute_Name => Name_Pos,
 581                 Expressions => New_List (
 582                   Make_Attribute_Reference (Loc,
 583                     Prefix => New_Occurrence_Of (Rtyp, Loc),
 584                     Attribute_Name => Name_Last))));
 585
 586             Prepend_To (Args,
 587               Make_Attribute_Reference (Loc,
 588                 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
 589                 Attribute_Name => Name_Address));
 590
 591             Prepend_To (Args,
 592               New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
 593
 594             Rewrite (N,
 595               Make_Attribute_Reference (Loc,
 596                 Prefix => New_Reference_To (Typ, Loc),
 597                 Attribute_Name => Name_Val,
 598                 Expressions => New_List (
 599                   Make_Function_Call (Loc,
 600                     Name =>
 601                       New_Reference_To (RTE (Func), Loc),
 602                     Parameter_Associations => Args))));
 603
 604             Analyze_And_Resolve (N, Btyp);
 605          end if;
 606
 607          return;
 608       end if;
 609
 610       --  Fall through for all cases except user defined enumeration type
 611       --  and decimal types, with Vid set to the Id of the entity for the
 612       --  Value routine and Args set to the list of parameters for the call.
 613
 614       Rewrite (N,
 615         Convert_To (Btyp,
 616           Make_Function_Call (Loc,
 617             Name => New_Reference_To (RTE (Vid), Loc),
 618             Parameter_Associations => Args)));
 619
 620       Analyze_And_Resolve (N, Btyp);
 621    end Expand_Value_Attribute;
 622
 623    ----------------------------
 624    -- Expand_Width_Attribute --
 625    ----------------------------
 626
 627    --  The processing here also handles the case of Wide_Width. With the
 628    --  exceptions noted, the processing is identical
 629
 630    --  For scalar types derived from Boolean, character and integer types
 631    --  in package Standard. Note that the Width attribute is computed at
 632    --  compile time for all cases except those involving non-static sub-
 633    --  types. For such subtypes, typ'Width and typ'Wide_Width expands into:
 634
 635    --    Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
 636
 637    --  where
 638
 639    --    For types whose root type is Character
 640    --      xx = Width_Character (Wide_Width_Character for Wide_Width case)
 641    --      yy = Character
 642
 643    --    For types whose root type is Boolean
 644    --      xx = Width_Boolean
 645    --      yy = Boolean
 646
 647    --    For signed integer types
 648    --      xx = Width_Long_Long_Integer
 649    --      yy = Long_Long_Integer
 650
 651    --    For modular integer types
 652    --      xx = Width_Long_Long_Unsigned
 653    --      yy = Long_Long_Unsigned
 654
 655    --  For types derived from Wide_Character, typ'Width expands into
 656
 657    --    Result_Type (Width_Wide_Character (
 658    --      Wide_Character (typ'First),
 659    --      Wide_Character (typ'Last),
 660    --      Wide_Character_Encoding_Method);
 661
 662    --  and typ'Wide_Width expands into:
 663
 664    --    Result_Type (Wide_Width_Wide_Character (
 665    --      Wide_Character (typ'First),
 666    --      Wide_Character (typ'Last));
 667
 668    --  For real types, typ'Width and typ'Wide_Width expand into
 669
 670    --    if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
 671
 672    --  where btyp is the base type. This looks recursive but it isn't
 673    --  because the base type is always static, and hence the expression
 674    --  in the else is reduced to an integer literal.
 675
 676    --  For user defined enumeration types, typ'Width expands into
 677
 678    --    Result_Type (Width_Enumeration_NN
 679    --                  (typS,
 680    --                   typI'Address,
 681    --                   typ'Pos (typ'First),
 682    --                   typ'Pos (Typ'Last)));
 683
 684    --  and typ'Wide_Width expands into:
 685
 686    --    Result_Type (Wide_Width_Enumeration_NN
 687    --                  (typS,
 688    --                   typI,
 689    --                   typ'Pos (typ'First),
 690    --                   typ'Pos (Typ'Last))
 691    --                   Wide_Character_Encoding_Method);
 692
 693    --  where typS and typI are the enumeration image strings and
 694    --  indexes table, as described in Build_Enumeration_Image_Tables.
 695    --  NN is 8/16/32 for depending on the element type for typI.
 696
 697    procedure Expand_Width_Attribute (N : Node_Id; Wide : Boolean) is
 698       Loc     : constant Source_Ptr := Sloc (N);
 699       Typ     : constant Entity_Id  := Etype (N);
 700       Pref    : constant Node_Id    := Prefix (N);
 701       Ptyp    : constant Entity_Id  := Etype (Pref);
 702       Rtyp    : constant Entity_Id  := Root_Type (Ptyp);
 703       XX      : RE_Id;
 704       YY      : Entity_Id;
 705       Arglist : List_Id;
 706       Ttyp    : Entity_Id;
 707
 708    begin
 709       --  Types derived from Standard.Boolean
 710
 711       if Rtyp = Standard_Boolean then
 712          XX := RE_Width_Boolean;
 713          YY := Rtyp;
 714
 715       --  Types derived from Standard.Character
 716
 717       elsif Rtyp = Standard_Character then
 718          if not Wide then
 719             XX := RE_Width_Character;
 720          else
 721             XX := RE_Wide_Width_Character;
 722          end if;
 723
 724          YY := Rtyp;
 725
 726       --  Types derived from Standard.Wide_Character
 727
 728       elsif Rtyp = Standard_Wide_Character then
 729          if not Wide then
 730             XX := RE_Width_Wide_Character;
 731          else
 732             XX := RE_Wide_Width_Wide_Character;
 733          end if;
 734
 735          YY := Rtyp;
 736
 737       --  Signed integer types
 738
 739       elsif Is_Signed_Integer_Type (Rtyp) then
 740          XX := RE_Width_Long_Long_Integer;
 741          YY := Standard_Long_Long_Integer;
 742
 743       --  Modular integer types
 744
 745       elsif Is_Modular_Integer_Type (Rtyp) then
 746          XX := RE_Width_Long_Long_Unsigned;
 747          YY := RTE (RE_Long_Long_Unsigned);
 748
 749       --  Real types
 750
 751       elsif Is_Real_Type (Rtyp) then
 752
 753          Rewrite (N,
 754            Make_Conditional_Expression (Loc,
 755              Expressions => New_List (
 756
 757                Make_Op_Gt (Loc,
 758                  Left_Opnd =>
 759                    Make_Attribute_Reference (Loc,
 760                      Prefix => New_Reference_To (Ptyp, Loc),
 761                      Attribute_Name => Name_First),
 762
 763                  Right_Opnd =>
 764                    Make_Attribute_Reference (Loc,
 765                      Prefix => New_Reference_To (Ptyp, Loc),
 766                      Attribute_Name => Name_Last)),
 767
 768                Make_Integer_Literal (Loc, 0),
 769
 770                Make_Attribute_Reference (Loc,
 771                  Prefix => New_Reference_To (Base_Type (Ptyp), Loc),
 772                  Attribute_Name => Name_Width))));
 773
 774          Analyze_And_Resolve (N, Typ);
 775          return;
 776
 777       --  User defined enumeration types
 778
 779       else
 780          pragma Assert (Is_Enumeration_Type (Rtyp));
 781
 782          Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
 783
 784          if not Wide then
 785             if Ttyp = Standard_Integer_8 then
 786                XX := RE_Width_Enumeration_8;
 787             elsif Ttyp = Standard_Integer_16  then
 788                XX := RE_Width_Enumeration_16;
 789             else
 790                XX := RE_Width_Enumeration_32;
 791             end if;
 792
 793          else
 794             if Ttyp = Standard_Integer_8 then
 795                XX := RE_Wide_Width_Enumeration_8;
 796             elsif Ttyp = Standard_Integer_16  then
 797                XX := RE_Wide_Width_Enumeration_16;
 798             else
 799                XX := RE_Wide_Width_Enumeration_32;
 800             end if;
 801          end if;
 802
 803          Arglist :=
 804            New_List (
 805              New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
 806
 807              Make_Attribute_Reference (Loc,
 808                Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
 809                Attribute_Name => Name_Address),
 810
 811              Make_Attribute_Reference (Loc,
 812                Prefix => New_Reference_To (Ptyp, Loc),
 813                Attribute_Name => Name_Pos,
 814
 815                Expressions => New_List (
 816                  Make_Attribute_Reference (Loc,
 817                    Prefix => New_Reference_To (Ptyp, Loc),
 818                    Attribute_Name => Name_First))),
 819
 820              Make_Attribute_Reference (Loc,
 821                Prefix => New_Reference_To (Ptyp, Loc),
 822                Attribute_Name => Name_Pos,
 823
 824                Expressions => New_List (
 825                  Make_Attribute_Reference (Loc,
 826                    Prefix => New_Reference_To (Ptyp, Loc),
 827                    Attribute_Name => Name_Last))));
 828
 829          --  For enumeration'Wide_Width, add encoding method parameter
 830
 831          if Wide then
 832             Append_To (Arglist,
 833               Make_Integer_Literal (Loc,
 834                 Intval => Int (Wide_Character_Encoding_Method)));
 835          end if;
 836
 837          Rewrite (N,
 838            Convert_To (Typ,
 839              Make_Function_Call (Loc,
 840                Name => New_Reference_To (RTE (XX), Loc),
 841                Parameter_Associations => Arglist)));
 842
 843          Analyze_And_Resolve (N, Typ);
 844          return;
 845       end if;
 846
 847       --  If we fall through XX and YY are set
 848
 849       Arglist := New_List (
 850         Convert_To (YY,
 851           Make_Attribute_Reference (Loc,
 852             Prefix => New_Reference_To (Ptyp, Loc),
 853             Attribute_Name => Name_First)),
 854
 855         Convert_To (YY,
 856           Make_Attribute_Reference (Loc,
 857             Prefix => New_Reference_To (Ptyp, Loc),
 858             Attribute_Name => Name_Last)));
 859
 860       --  For Wide_Character'Width, add encoding method parameter
 861
 862       if Rtyp = Standard_Wide_Character and then Wide then
 863          Append_To (Arglist,
 864            Make_Integer_Literal (Loc,
 865              Intval => Int (Wide_Character_Encoding_Method)));
 866       end if;
 867
 868       Rewrite (N,
 869         Convert_To (Typ,
 870           Make_Function_Call (Loc,
 871             Name => New_Reference_To (RTE (XX), Loc),
 872             Parameter_Associations => Arglist)));
 873
 874       Analyze_And_Resolve (N, Typ);
 875    end Expand_Width_Attribute;
 876
 877 end Exp_Imgv;