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