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