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