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-2007, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Atree;    use Atree;
  27 with Casing;   use Casing;
  28 with Checks;   use Checks;
  29 with Einfo;    use Einfo;
  30 with Exp_Util; use Exp_Util;
  31 with Lib;      use Lib;
  32 with Namet;    use Namet;
  33 with Nmake;    use Nmake;
  34 with Nlists;   use Nlists;
  35 with Opt;      use Opt;
  36 with Rtsfind;  use Rtsfind;
  37 with Sem_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    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 = Boolean, true if Ada 2005 mode, False otherwise
 195
 196    --    For types whose root type is Wide_Wide_Character
 197    --      xx = Wide_Wide_haracter
 198    --      tv = Wide_Wide_Character (Expr)
 199
 200    --    For floating-point types
 201    --      xx = Floating_Point
 202    --      tv = Long_Long_Float (Expr)
 203    --      pm = typ'Digits
 204
 205    --    For ordinary fixed-point types
 206    --      xx = Ordinary_Fixed_Point
 207    --      tv = Long_Long_Float (Expr)
 208    --      pm = typ'Aft
 209
 210    --    For decimal fixed-point types with size = Integer'Size
 211    --      xx = Decimal
 212    --      tv = Integer (Expr)
 213    --      pm = typ'Scale
 214
 215    --    For decimal fixed-point types with size > Integer'Size
 216    --      xx = Long_Long_Decimal
 217    --      tv = Long_Long_Integer (Expr)
 218    --      pm = typ'Scale
 219
 220    --    Note: for the decimal fixed-point type cases, the conversion is
 221    --    done literally without scaling (i.e. the actual expression that
 222    --    is generated is Image_xx (tp?(Expr) [, pm])
 223
 224    --  For enumeration types other than those declared packages Standard
 225    --  or System, typ'Image (X) expands into:
 226
 227    --    Image_Enumeration_NN (typ'Pos (X), typS, typI'Address)
 228
 229    --  where typS and typI are the entities constructed as described in
 230    --  the spec for the procedure Build_Enumeration_Image_Tables and NN
 231    --  is 32/16/8 depending on the element type of Lit_Indexes.
 232
 233    procedure Expand_Image_Attribute (N : Node_Id) is
 234       Loc      : constant Source_Ptr := Sloc (N);
 235       Exprs    : constant List_Id    := Expressions (N);
 236       Pref     : constant Node_Id    := Prefix (N);
 237       Ptyp     : constant Entity_Id  := Entity (Pref);
 238       Rtyp     : constant Entity_Id  := Root_Type (Ptyp);
 239       Expr     : constant Node_Id    := Relocate_Node (First (Exprs));
 240       Imid     : RE_Id;
 241       Tent     : Entity_Id;
 242       Arglist  : List_Id;
 243       Func     : RE_Id;
 244       Ttyp     : Entity_Id;
 245       Func_Ent : Entity_Id;
 246
 247    begin
 248       if Rtyp = Standard_Boolean then
 249          Imid := RE_Image_Boolean;
 250          Tent := Rtyp;
 251
 252       elsif Rtyp = Standard_Character then
 253          Imid := RE_Image_Character;
 254          Tent := Rtyp;
 255
 256       elsif Rtyp = Standard_Wide_Character then
 257          Imid := RE_Image_Wide_Character;
 258          Tent := Rtyp;
 259
 260       elsif Rtyp = Standard_Wide_Wide_Character then
 261          Imid := RE_Image_Wide_Wide_Character;
 262          Tent := Rtyp;
 263
 264       elsif Is_Signed_Integer_Type (Rtyp) then
 265          if Esize (Rtyp) <= Esize (Standard_Integer) then
 266             Imid := RE_Image_Integer;
 267             Tent := Standard_Integer;
 268          else
 269             Imid := RE_Image_Long_Long_Integer;
 270             Tent := Standard_Long_Long_Integer;
 271          end if;
 272
 273       elsif Is_Modular_Integer_Type (Rtyp) then
 274          if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
 275             Imid := RE_Image_Unsigned;
 276             Tent := RTE (RE_Unsigned);
 277          else
 278             Imid := RE_Image_Long_Long_Unsigned;
 279             Tent := RTE (RE_Long_Long_Unsigned);
 280          end if;
 281
 282       elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
 283          if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
 284             Imid := RE_Image_Decimal;
 285             Tent := Standard_Integer;
 286          else
 287             Imid := RE_Image_Long_Long_Decimal;
 288             Tent := Standard_Long_Long_Integer;
 289          end if;
 290
 291       elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
 292          Imid := RE_Image_Ordinary_Fixed_Point;
 293          Tent := Standard_Long_Long_Float;
 294
 295       elsif Is_Floating_Point_Type (Rtyp) then
 296          Imid := RE_Image_Floating_Point;
 297          Tent := Standard_Long_Long_Float;
 298
 299       --  Only other possibility is user defined enumeration type
 300
 301       else
 302          if Discard_Names (First_Subtype (Ptyp))
 303            or else No (Lit_Strings (Root_Type (Ptyp)))
 304          then
 305             --  When pragma Discard_Names applies to the first subtype,
 306             --  then build (Pref'Pos)'Img.
 307
 308             Rewrite (N,
 309               Make_Attribute_Reference (Loc,
 310                 Prefix =>
 311                    Make_Attribute_Reference (Loc,
 312                      Prefix         => Pref,
 313                      Attribute_Name => Name_Pos,
 314                      Expressions    => New_List (Expr)),
 315                 Attribute_Name =>
 316                   Name_Img));
 317             Analyze_And_Resolve (N, Standard_String);
 318
 319          else
 320             --  Here we get the Image of an enumeration type
 321
 322             Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
 323
 324             if Ttyp = Standard_Integer_8 then
 325                Func := RE_Image_Enumeration_8;
 326             elsif Ttyp = Standard_Integer_16  then
 327                Func := RE_Image_Enumeration_16;
 328             else
 329                Func := RE_Image_Enumeration_32;
 330             end if;
 331
 332             --  Apply a validity check, since it is a bit drastic to
 333             --  get a completely junk image value for an invalid value.
 334
 335             if not Expr_Known_Valid (Expr) then
 336                Insert_Valid_Check (Expr);
 337             end if;
 338
 339             Rewrite (N,
 340               Make_Function_Call (Loc,
 341                 Name => New_Occurrence_Of (RTE (Func), Loc),
 342                 Parameter_Associations => New_List (
 343                   Make_Attribute_Reference (Loc,
 344                     Attribute_Name => Name_Pos,
 345                     Prefix         => New_Occurrence_Of (Ptyp, Loc),
 346                     Expressions    => New_List (Expr)),
 347                   New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
 348                   Make_Attribute_Reference (Loc,
 349                     Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
 350                     Attribute_Name => Name_Address))));
 351
 352             Analyze_And_Resolve (N, Standard_String);
 353          end if;
 354
 355          return;
 356       end if;
 357
 358       --  If we fall through, we have one of the cases that is handled by
 359       --  calling one of the System.Img_xx routines and Imid is set to the
 360       --  RE_Id for the function to be called.
 361
 362       Func_Ent := RTE (Imid);
 363
 364       --  If the function entity is empty, that means we have a case in
 365       --  no run time mode where the operation is not allowed, and an
 366       --  appropriate diagnostic has already been issued.
 367
 368       if No (Func_Ent) then
 369          return;
 370       end if;
 371
 372       --  Otherwise prepare arguments for run-time call
 373
 374       Arglist := New_List (Convert_To (Tent, Relocate_Node (Expr)));
 375
 376       --  For floating-point types, append Digits argument
 377
 378       if Is_Floating_Point_Type (Rtyp) then
 379          Append_To (Arglist,
 380            Make_Attribute_Reference (Loc,
 381              Prefix         => New_Reference_To (Ptyp, Loc),
 382              Attribute_Name => Name_Digits));
 383
 384       --  For ordinary fixed-point types, append Aft parameter
 385
 386       elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
 387          Append_To (Arglist,
 388            Make_Attribute_Reference (Loc,
 389              Prefix         => New_Reference_To (Ptyp, Loc),
 390              Attribute_Name => Name_Aft));
 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
 403          --  For Wide_Character, append Ada 2005 indication
 404
 405       elsif Rtyp = Standard_Wide_Character then
 406          Append_To (Arglist,
 407            New_Reference_To (Boolean_Literals (Ada_Version >= Ada_05), Loc));
 408       end if;
 409
 410       Rewrite (N,
 411         Make_Function_Call (Loc,
 412           Name => New_Reference_To (Func_Ent, Loc),
 413           Parameter_Associations => Arglist));
 414
 415       Analyze_And_Resolve (N, Standard_String);
 416    end Expand_Image_Attribute;
 417
 418    ----------------------------
 419    -- Expand_Value_Attribute --
 420    ----------------------------
 421
 422    --  For scalar types derived from Boolean, Character and integer types
 423    --  in package Standard, typ'Value (X) expands into:
 424
 425    --    btyp (Value_xx (X))
 426
 427    --  where btyp is he base type of the prefix
 428
 429    --    For types whose root type is Character
 430    --      xx = Character
 431
 432    --    For types whose root type is Wide_Character
 433    --      xx = Wide_Character
 434
 435    --    For types whose root type is Wide_Wide_Character
 436    --      xx = Wide_Wide_Character
 437
 438    --    For types whose root type is Boolean
 439    --      xx = Boolean
 440
 441    --    For signed integer types with size <= Integer'Size
 442    --      xx = Integer
 443
 444    --    For other signed integer types
 445    --      xx = Long_Long_Integer
 446
 447    --    For modular types with modulus <= System.Unsigned_Types.Unsigned
 448    --      xx = Unsigned
 449
 450    --    For other modular integer types
 451    --      xx = Long_Long_Unsigned
 452
 453    --    For floating-point types and ordinary fixed-point types
 454    --      xx = Real
 455
 456    --  For Wide_[Wide_]Character types, typ'Value (X) expands into:
 457
 458    --    btyp (Value_xx (X, EM))
 459
 460    --  where btyp is the base type of the prefix, and EM is the encoding method
 461
 462    --  For decimal types with size <= Integer'Size, typ'Value (X)
 463    --  expands into
 464
 465    --    btyp?(Value_Decimal (X, typ'Scale));
 466
 467    --  For all other decimal types, typ'Value (X) expands into
 468
 469    --    btyp?(Value_Long_Long_Decimal (X, typ'Scale))
 470
 471    --  For enumeration types other than those derived from types Boolean,
 472    --  Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
 473
 474    --    Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
 475
 476    --  where typS and typI and the Lit_Strings and Lit_Indexes entities
 477    --  from T's root type entitym and Num is Enum'Pos (Enum'Last). The
 478    --  Value_Enumeration_NN function will search the tables looking for
 479    --  X and return the position number in the table if found which is
 480    --  used to provide the result of 'Value (using Enum'Val). If the
 481    --  value is not found Constraint_Error is raised. The suffix _NN
 482    --  depends on the element type of typI.
 483
 484    procedure Expand_Value_Attribute (N : Node_Id) is
 485       Loc   : constant Source_Ptr := Sloc (N);
 486       Typ   : constant Entity_Id  := Etype (N);
 487       Btyp  : constant Entity_Id  := Base_Type (Typ);
 488       Rtyp  : constant Entity_Id  := Root_Type (Typ);
 489       Exprs : constant List_Id    := Expressions (N);
 490       Vid   : RE_Id;
 491       Args  : List_Id;
 492       Func  : RE_Id;
 493       Ttyp  : Entity_Id;
 494
 495    begin
 496       Args := Exprs;
 497
 498       if Rtyp = Standard_Character then
 499          Vid := RE_Value_Character;
 500
 501       elsif Rtyp = Standard_Boolean then
 502          Vid := RE_Value_Boolean;
 503
 504       elsif Rtyp = Standard_Wide_Character then
 505          Vid := RE_Value_Wide_Character;
 506
 507          Append_To (Args,
 508            Make_Integer_Literal (Loc,
 509              Intval => Int (Wide_Character_Encoding_Method)));
 510
 511       elsif Rtyp = Standard_Wide_Wide_Character then
 512          Vid := RE_Value_Wide_Wide_Character;
 513
 514          Append_To (Args,
 515            Make_Integer_Literal (Loc,
 516              Intval => Int (Wide_Character_Encoding_Method)));
 517
 518       elsif     Rtyp = Base_Type (Standard_Short_Short_Integer)
 519         or else Rtyp = Base_Type (Standard_Short_Integer)
 520         or else Rtyp = Base_Type (Standard_Integer)
 521       then
 522          Vid := RE_Value_Integer;
 523
 524       elsif Is_Signed_Integer_Type (Rtyp) then
 525          Vid := RE_Value_Long_Long_Integer;
 526
 527       elsif Is_Modular_Integer_Type (Rtyp) then
 528          if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
 529             Vid := RE_Value_Unsigned;
 530          else
 531             Vid := RE_Value_Long_Long_Unsigned;
 532          end if;
 533
 534       elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
 535          if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
 536             Vid := RE_Value_Decimal;
 537          else
 538             Vid := RE_Value_Long_Long_Decimal;
 539          end if;
 540
 541          Append_To (Args,
 542            Make_Attribute_Reference (Loc,
 543              Prefix => New_Reference_To (Typ, Loc),
 544              Attribute_Name => Name_Scale));
 545
 546          Rewrite (N,
 547            OK_Convert_To (Btyp,
 548              Make_Function_Call (Loc,
 549                Name => New_Reference_To (RTE (Vid), Loc),
 550                Parameter_Associations => Args)));
 551
 552          Set_Etype (N, Btyp);
 553          Analyze_And_Resolve (N, Btyp);
 554          return;
 555
 556       elsif Is_Real_Type (Rtyp) then
 557          Vid := RE_Value_Real;
 558
 559       --  Only other possibility is user defined enumeration type
 560
 561       else
 562          pragma Assert (Is_Enumeration_Type (Rtyp));
 563
 564          --  Case of pragma Discard_Names, transform the Value
 565          --  attribute to Btyp'Val (Long_Long_Integer'Value (Args))
 566
 567          if Discard_Names (First_Subtype (Typ))
 568            or else No (Lit_Strings (Rtyp))
 569          then
 570             Rewrite (N,
 571               Make_Attribute_Reference (Loc,
 572                 Prefix => New_Reference_To (Btyp, Loc),
 573                 Attribute_Name => Name_Val,
 574                 Expressions => New_List (
 575                   Make_Attribute_Reference (Loc,
 576                     Prefix =>
 577                       New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
 578                     Attribute_Name => Name_Value,
 579                     Expressions => Args))));
 580
 581             Analyze_And_Resolve (N, Btyp);
 582
 583          --  Here for normal case where we have enumeration tables, this
 584          --  is where we build
 585
 586          --    T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
 587
 588          else
 589             Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
 590
 591             if Ttyp = Standard_Integer_8 then
 592                Func := RE_Value_Enumeration_8;
 593             elsif Ttyp = Standard_Integer_16  then
 594                Func := RE_Value_Enumeration_16;
 595             else
 596                Func := RE_Value_Enumeration_32;
 597             end if;
 598
 599             Prepend_To (Args,
 600               Make_Attribute_Reference (Loc,
 601                 Prefix => New_Occurrence_Of (Rtyp, Loc),
 602                 Attribute_Name => Name_Pos,
 603                 Expressions => New_List (
 604                   Make_Attribute_Reference (Loc,
 605                     Prefix => New_Occurrence_Of (Rtyp, Loc),
 606                     Attribute_Name => Name_Last))));
 607
 608             Prepend_To (Args,
 609               Make_Attribute_Reference (Loc,
 610                 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
 611                 Attribute_Name => Name_Address));
 612
 613             Prepend_To (Args,
 614               New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
 615
 616             Rewrite (N,
 617               Make_Attribute_Reference (Loc,
 618                 Prefix => New_Reference_To (Typ, Loc),
 619                 Attribute_Name => Name_Val,
 620                 Expressions => New_List (
 621                   Make_Function_Call (Loc,
 622                     Name =>
 623                       New_Reference_To (RTE (Func), Loc),
 624                     Parameter_Associations => Args))));
 625
 626             Analyze_And_Resolve (N, Btyp);
 627          end if;
 628
 629          return;
 630       end if;
 631
 632       --  Fall through for all cases except user defined enumeration type
 633       --  and decimal types, with Vid set to the Id of the entity for the
 634       --  Value routine and Args set to the list of parameters for the call.
 635
 636       --  Compiling package Ada.Tags under No_Run_Time_Mode we disable the
 637       --  expansion of the attribute into the function call statement to avoid
 638       --  generating spurious errors caused by the use of Integer_Address'Value
 639       --  in our implementation of Ada.Tags.Internal_Tag
 640
 641       --  Seems like a bit of a kludge, there should be a better way ???
 642
 643       --  There is a better way, you should also test RTE_Available ???
 644
 645       if No_Run_Time_Mode
 646         and then Rtyp = RTE (RE_Integer_Address)
 647         and then RTU_Loaded (Ada_Tags)
 648         and then Cunit_Entity (Current_Sem_Unit)
 649                    = Body_Entity (RTU_Entity (Ada_Tags))
 650       then
 651          Rewrite (N,
 652            Unchecked_Convert_To (Rtyp,
 653              Make_Integer_Literal (Loc, Uint_0)));
 654       else
 655          Rewrite (N,
 656            Convert_To (Btyp,
 657              Make_Function_Call (Loc,
 658                Name => New_Reference_To (RTE (Vid), Loc),
 659                Parameter_Associations => Args)));
 660       end if;
 661
 662       Analyze_And_Resolve (N, Btyp);
 663    end Expand_Value_Attribute;
 664
 665    ----------------------------
 666    -- Expand_Width_Attribute --
 667    ----------------------------
 668
 669    --  The processing here also handles the case of Wide_[Wide_]Width. With the
 670    --  exceptions noted, the processing is identical
 671
 672    --  For scalar types derived from Boolean, character and integer types
 673    --  in package Standard. Note that the Width attribute is computed at
 674    --  compile time for all cases except those involving non-static sub-
 675    --  types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
 676
 677    --    Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
 678
 679    --  where
 680
 681    --    For types whose root type is Character
 682    --      xx = Width_Character
 683    --      yy = Character
 684
 685    --    For types whose root type is Wide_Character
 686    --      xx = Wide_Width_Character
 687    --      yy = Character
 688
 689    --    For types whose root type is Wide_Wide_Character
 690    --      xx = Wide_Wide_Width_Character
 691    --      yy = Character
 692
 693    --    For types whose root type is Boolean
 694    --      xx = Width_Boolean
 695    --      yy = Boolean
 696
 697    --    For signed integer types
 698    --      xx = Width_Long_Long_Integer
 699    --      yy = Long_Long_Integer
 700
 701    --    For modular integer types
 702    --      xx = Width_Long_Long_Unsigned
 703    --      yy = Long_Long_Unsigned
 704
 705    --  For types derived from Wide_Character, typ'Width expands into
 706
 707    --    Result_Type (Width_Wide_Character (
 708    --      Wide_Character (typ'First),
 709    --      Wide_Character (typ'Last),
 710
 711    --  and typ'Wide_Width expands into:
 712
 713    --    Result_Type (Wide_Width_Wide_Character (
 714    --      Wide_Character (typ'First),
 715    --      Wide_Character (typ'Last));
 716
 717    --  and typ'Wide_Wide_Width expands into
 718
 719    --    Result_Type (Wide_Wide_Width_Wide_Character (
 720    --      Wide_Character (typ'First),
 721    --      Wide_Character (typ'Last));
 722
 723    --  For types derived from Wide_Wide_Character, typ'Width expands into
 724
 725    --    Result_Type (Width_Wide_Wide_Character (
 726    --      Wide_Wide_Character (typ'First),
 727    --      Wide_Wide_Character (typ'Last),
 728
 729    --  and typ'Wide_Width expands into:
 730
 731    --    Result_Type (Wide_Width_Wide_Wide_Character (
 732    --      Wide_Wide_Character (typ'First),
 733    --      Wide_Wide_Character (typ'Last));
 734
 735    --  and typ'Wide_Wide_Width expands into
 736
 737    --    Result_Type (Wide_Wide_Width_Wide_Wide_Char (
 738    --      Wide_Wide_Character (typ'First),
 739    --      Wide_Wide_Character (typ'Last));
 740
 741    --  For real types, typ'Width and typ'Wide_[Wide_]Width expand into
 742
 743    --    if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
 744
 745    --  where btyp is the base type. This looks recursive but it isn't
 746    --  because the base type is always static, and hence the expression
 747    --  in the else is reduced to an integer literal.
 748
 749    --  For user defined enumeration types, typ'Width expands into
 750
 751    --    Result_Type (Width_Enumeration_NN
 752    --                  (typS,
 753    --                   typI'Address,
 754    --                   typ'Pos (typ'First),
 755    --                   typ'Pos (Typ'Last)));
 756
 757    --  and typ'Wide_Width expands into:
 758
 759    --    Result_Type (Wide_Width_Enumeration_NN
 760    --                  (typS,
 761    --                   typI,
 762    --                   typ'Pos (typ'First),
 763    --                   typ'Pos (Typ'Last))
 764    --                   Wide_Character_Encoding_Method);
 765
 766    --  and typ'Wide_Wide_Width expands into:
 767
 768    --    Result_Type (Wide_Wide_Width_Enumeration_NN
 769    --                  (typS,
 770    --                   typI,
 771    --                   typ'Pos (typ'First),
 772    --                   typ'Pos (Typ'Last))
 773    --                   Wide_Character_Encoding_Method);
 774
 775    --  where typS and typI are the enumeration image strings and
 776    --  indexes table, as described in Build_Enumeration_Image_Tables.
 777    --  NN is 8/16/32 for depending on the element type for typI.
 778
 779    procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is
 780       Loc     : constant Source_Ptr := Sloc (N);
 781       Typ     : constant Entity_Id  := Etype (N);
 782       Pref    : constant Node_Id    := Prefix (N);
 783       Ptyp    : constant Entity_Id  := Etype (Pref);
 784       Rtyp    : constant Entity_Id  := Root_Type (Ptyp);
 785       XX      : RE_Id;
 786       YY      : Entity_Id;
 787       Arglist : List_Id;
 788       Ttyp    : Entity_Id;
 789
 790    begin
 791       --  Types derived from Standard.Boolean
 792
 793       if Rtyp = Standard_Boolean then
 794          XX := RE_Width_Boolean;
 795          YY := Rtyp;
 796
 797       --  Types derived from Standard.Character
 798
 799       elsif Rtyp = Standard_Character then
 800          case Attr is
 801             when Normal    => XX := RE_Width_Character;
 802             when Wide      => XX := RE_Wide_Width_Character;
 803             when Wide_Wide => XX := RE_Wide_Wide_Width_Character;
 804          end case;
 805
 806          YY := Rtyp;
 807
 808       --  Types derived from Standard.Wide_Character
 809
 810       elsif Rtyp = Standard_Wide_Character then
 811          case Attr is
 812             when Normal    => XX := RE_Width_Wide_Character;
 813             when Wide      => XX := RE_Wide_Width_Wide_Character;
 814             when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character;
 815          end case;
 816
 817          YY := Rtyp;
 818
 819       --  Types derived from Standard.Wide_Wide_Character
 820
 821       elsif Rtyp = Standard_Wide_Wide_Character then
 822          case Attr is
 823             when Normal    => XX := RE_Width_Wide_Wide_Character;
 824             when Wide      => XX := RE_Wide_Width_Wide_Wide_Character;
 825             when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char;
 826          end case;
 827
 828          YY := Rtyp;
 829
 830       --  Signed integer types
 831
 832       elsif Is_Signed_Integer_Type (Rtyp) then
 833          XX := RE_Width_Long_Long_Integer;
 834          YY := Standard_Long_Long_Integer;
 835
 836       --  Modular integer types
 837
 838       elsif Is_Modular_Integer_Type (Rtyp) then
 839          XX := RE_Width_Long_Long_Unsigned;
 840          YY := RTE (RE_Long_Long_Unsigned);
 841
 842       --  Real types
 843
 844       elsif Is_Real_Type (Rtyp) then
 845
 846          Rewrite (N,
 847            Make_Conditional_Expression (Loc,
 848              Expressions => New_List (
 849
 850                Make_Op_Gt (Loc,
 851                  Left_Opnd =>
 852                    Make_Attribute_Reference (Loc,
 853                      Prefix => New_Reference_To (Ptyp, Loc),
 854                      Attribute_Name => Name_First),
 855
 856                  Right_Opnd =>
 857                    Make_Attribute_Reference (Loc,
 858                      Prefix => New_Reference_To (Ptyp, Loc),
 859                      Attribute_Name => Name_Last)),
 860
 861                Make_Integer_Literal (Loc, 0),
 862
 863                Make_Attribute_Reference (Loc,
 864                  Prefix => New_Reference_To (Base_Type (Ptyp), Loc),
 865                  Attribute_Name => Name_Width))));
 866
 867          Analyze_And_Resolve (N, Typ);
 868          return;
 869
 870       --  User defined enumeration types
 871
 872       else
 873          pragma Assert (Is_Enumeration_Type (Rtyp));
 874
 875          if Discard_Names (Rtyp) then
 876
 877             --  This is a configurable run-time, or else a restriction is in
 878             --  effect. In either case the attribute cannot be supported. Force
 879             --  a load error from Rtsfind to generate an appropriate message,
 880             --  as is done with other ZFP violations.
 881
 882             declare
 883                pragma Warnings (Off); -- since Discard is unreferenced
 884                Discard : constant Entity_Id := RTE (RE_Null);
 885                pragma Warnings (On);
 886             begin
 887                return;
 888             end;
 889          end if;
 890
 891          Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
 892
 893          case Attr is
 894             when Normal =>
 895                if Ttyp = Standard_Integer_8 then
 896                   XX := RE_Width_Enumeration_8;
 897                elsif Ttyp = Standard_Integer_16  then
 898                   XX := RE_Width_Enumeration_16;
 899                else
 900                   XX := RE_Width_Enumeration_32;
 901                end if;
 902
 903             when Wide =>
 904                if Ttyp = Standard_Integer_8 then
 905                   XX := RE_Wide_Width_Enumeration_8;
 906                elsif Ttyp = Standard_Integer_16  then
 907                   XX := RE_Wide_Width_Enumeration_16;
 908                else
 909                   XX := RE_Wide_Width_Enumeration_32;
 910                end if;
 911
 912             when Wide_Wide =>
 913                if Ttyp = Standard_Integer_8 then
 914                   XX := RE_Wide_Wide_Width_Enumeration_8;
 915                elsif Ttyp = Standard_Integer_16  then
 916                   XX := RE_Wide_Wide_Width_Enumeration_16;
 917                else
 918                   XX := RE_Wide_Wide_Width_Enumeration_32;
 919                end if;
 920          end case;
 921
 922          Arglist :=
 923            New_List (
 924              New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
 925
 926              Make_Attribute_Reference (Loc,
 927                Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
 928                Attribute_Name => Name_Address),
 929
 930              Make_Attribute_Reference (Loc,
 931                Prefix => New_Reference_To (Ptyp, Loc),
 932                Attribute_Name => Name_Pos,
 933
 934                Expressions => New_List (
 935                  Make_Attribute_Reference (Loc,
 936                    Prefix => New_Reference_To (Ptyp, Loc),
 937                    Attribute_Name => Name_First))),
 938
 939              Make_Attribute_Reference (Loc,
 940                Prefix => New_Reference_To (Ptyp, Loc),
 941                Attribute_Name => Name_Pos,
 942
 943                Expressions => New_List (
 944                  Make_Attribute_Reference (Loc,
 945                    Prefix => New_Reference_To (Ptyp, Loc),
 946                    Attribute_Name => Name_Last))));
 947
 948          Rewrite (N,
 949            Convert_To (Typ,
 950              Make_Function_Call (Loc,
 951                Name => New_Reference_To (RTE (XX), Loc),
 952                Parameter_Associations => Arglist)));
 953
 954          Analyze_And_Resolve (N, Typ);
 955          return;
 956       end if;
 957
 958       --  If we fall through XX and YY are set
 959
 960       Arglist := New_List (
 961         Convert_To (YY,
 962           Make_Attribute_Reference (Loc,
 963             Prefix => New_Reference_To (Ptyp, Loc),
 964             Attribute_Name => Name_First)),
 965
 966         Convert_To (YY,
 967           Make_Attribute_Reference (Loc,
 968             Prefix => New_Reference_To (Ptyp, Loc),
 969             Attribute_Name => Name_Last)));
 970
 971       Rewrite (N,
 972         Convert_To (Typ,
 973           Make_Function_Call (Loc,
 974             Name => New_Reference_To (RTE (XX), Loc),
 975             Parameter_Associations => Arglist)));
 976
 977       Analyze_And_Resolve (N, Typ);
 978    end Expand_Width_Attribute;
 979
 980 end Exp_Imgv;