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