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 cases other than user defined enumeration types, the scheme
 159    --  is as follows. First we insert the following code:
 160
 161    --    Snn : String (1 .. rt'Width);
 162    --    Pnn : Natural;
 163    --    Image_xx (tv, Snn, Pnn [,pm]);
 164    --
 165    --  and then Expr is replaced by Snn (1 .. Pnn)
 166
 167    --  In the above expansion:
 168
 169    --    rt is the root type of the expression
 170    --    tv is the expression with the value, usually a type conversion
 171    --    pm is an extra parameter present in some cases
 172
 173    --  The following table shows tv, xx, and (if used) pm for the various
 174    --  possible types of the argument:
 175
 176    --    For types whose root type is Character
 177    --      xx = Character
 178    --      tv = Character (Expr)
 179
 180    --    For types whose root type is Boolean
 181    --      xx = Boolean
 182    --      tv = Boolean (Expr)
 183
 184    --    For signed integer types with size <= Integer'Size
 185    --      xx = Integer
 186    --      tv = Integer (Expr)
 187
 188    --    For other signed integer types
 189    --      xx = Long_Long_Integer
 190    --      tv = Long_Long_Integer (Expr)
 191
 192    --    For modular types with modulus <= System.Unsigned_Types.Unsigned
 193    --      xx = Unsigned
 194    --      tv = System.Unsigned_Types.Unsigned (Expr)
 195
 196    --    For other modular integer types
 197    --      xx = Long_Long_Unsigned
 198    --      tv = System.Unsigned_Types.Long_Long_Unsigned (Expr)
 199
 200    --    For types whose root type is Wide_Character
 201    --      xx = Wide_Character
 202    --      tv = Wide_Character (Expr)
 203    --      pm = Boolean, true if Ada 2005 mode, False otherwise
 204
 205    --    For types whose root type is Wide_Wide_Character
 206    --      xx = Wide_Wide_Character
 207    --      tv = Wide_Wide_Character (Expr)
 208
 209    --    For floating-point types
 210    --      xx = Floating_Point
 211    --      tv = Long_Long_Float (Expr)
 212    --      pm = typ'Digits (typ = subtype of expression)
 213
 214    --    For ordinary fixed-point types
 215    --      xx = Ordinary_Fixed_Point
 216    --      tv = Long_Long_Float (Expr)
 217    --      pm = typ'Aft (typ = subtype of expression)
 218
 219    --    For decimal fixed-point types with size = Integer'Size
 220    --      xx = Decimal
 221    --      tv = Integer (Expr)
 222    --      pm = typ'Scale (typ = subtype of expression)
 223
 224    --    For decimal fixed-point types with size > Integer'Size
 225    --      xx = Long_Long_Decimal
 226    --      tv = Long_Long_Integer?(Expr) [convert with no scaling]
 227    --      pm = typ'Scale (typ = subtype of expression)
 228
 229    --  For enumeration types other than those declared packages Standard
 230    --  or System, Snn, Pnn, are expanded as above, but the call looks like:
 231
 232    --    Image_Enumeration_NN (rt'Pos (X), Snn, Pnn, typS, typI'Address)
 233
 234    --  where rt is the root type of the expression, and typS and typI are
 235    --  the entities constructed as described in the spec for the procedure
 236    --  Build_Enumeration_Image_Tables and NN is 32/16/8 depending on the
 237    --  element type of Lit_Indexes. The rewriting of the expression to
 238    --  Snn (1 .. Pnn) then occurs as in the other cases. A special case is
 239    --  when pragma Discard_Names applies, in which case we replace expr by:
 240
 241    --    Missing ???
 242
 243    procedure Expand_Image_Attribute (N : Node_Id) is
 244       Loc       : constant Source_Ptr := Sloc (N);
 245       Exprs     : constant List_Id    := Expressions (N);
 246       Pref      : constant Node_Id    := Prefix (N);
 247       Ptyp      : constant Entity_Id  := Entity (Pref);
 248       Rtyp      : constant Entity_Id  := Root_Type (Ptyp);
 249       Expr      : constant Node_Id    := Relocate_Node (First (Exprs));
 250       Imid      : RE_Id;
 251       Tent      : Entity_Id;
 252       Ttyp      : Entity_Id;
 253       Proc_Ent  : Entity_Id;
 254       Enum_Case : Boolean;
 255
 256       Arg_List : List_Id;
 257       --  List of arguments for run-time procedure call
 258
 259       Ins_List : List_Id;
 260       --  List of actions to be inserted
 261
 262       Snn : constant Entity_Id :=
 263               Make_Defining_Identifier (Loc,
 264                 Chars => New_Internal_Name ('S'));
 265
 266       Pnn : constant Entity_Id :=
 267               Make_Defining_Identifier (Loc,
 268                 Chars => New_Internal_Name ('P'));
 269
 270    begin
 271       --  Build declarations of Snn and Pnn to be inserted
 272
 273       Ins_List := New_List (
 274
 275          --  Snn : String (1 .. typ'Width);
 276
 277          Make_Object_Declaration (Loc,
 278             Defining_Identifier => Snn,
 279             Object_Definition   =>
 280               Make_Subtype_Indication (Loc,
 281                 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
 282                 Constraint   =>
 283                   Make_Index_Or_Discriminant_Constraint (Loc,
 284                     Constraints => New_List (
 285                       Make_Range (Loc,
 286                         Low_Bound  => Make_Integer_Literal (Loc, 1),
 287                         High_Bound =>
 288                           Make_Attribute_Reference (Loc,
 289                             Prefix         => New_Occurrence_Of (Rtyp, Loc),
 290                             Attribute_Name => Name_Width)))))),
 291
 292          --  Pnn : Natural;
 293
 294          Make_Object_Declaration (Loc,
 295            Defining_Identifier => Pnn,
 296            Object_Definition   => New_Occurrence_Of (Standard_Natural, Loc)));
 297
 298       --  Set Imid (RE_Id of procedure to call), and Tent, target for the
 299       --  type conversion of the first argument for all possibilities.
 300
 301       Enum_Case := False;
 302
 303       if Rtyp = Standard_Boolean then
 304          Imid := RE_Image_Boolean;
 305          Tent := Rtyp;
 306
 307       elsif Rtyp = Standard_Character then
 308          Imid := RE_Image_Character;
 309          Tent := Rtyp;
 310
 311       elsif Rtyp = Standard_Wide_Character then
 312          Imid := RE_Image_Wide_Character;
 313          Tent := Rtyp;
 314
 315       elsif Rtyp = Standard_Wide_Wide_Character then
 316          Imid := RE_Image_Wide_Wide_Character;
 317          Tent := Rtyp;
 318
 319       elsif Is_Signed_Integer_Type (Rtyp) then
 320          if Esize (Rtyp) <= Esize (Standard_Integer) then
 321             Imid := RE_Image_Integer;
 322             Tent := Standard_Integer;
 323          else
 324             Imid := RE_Image_Long_Long_Integer;
 325             Tent := Standard_Long_Long_Integer;
 326          end if;
 327
 328       elsif Is_Modular_Integer_Type (Rtyp) then
 329          if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
 330             Imid := RE_Image_Unsigned;
 331             Tent := RTE (RE_Unsigned);
 332          else
 333             Imid := RE_Image_Long_Long_Unsigned;
 334             Tent := RTE (RE_Long_Long_Unsigned);
 335          end if;
 336
 337       elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
 338          if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
 339             Imid := RE_Image_Decimal;
 340             Tent := Standard_Integer;
 341          else
 342             Imid := RE_Image_Long_Long_Decimal;
 343             Tent := Standard_Long_Long_Integer;
 344          end if;
 345
 346       elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
 347          Imid := RE_Image_Ordinary_Fixed_Point;
 348          Tent := Standard_Long_Long_Float;
 349
 350       elsif Is_Floating_Point_Type (Rtyp) then
 351          Imid := RE_Image_Floating_Point;
 352          Tent := Standard_Long_Long_Float;
 353
 354       --  Only other possibility is user defined enumeration type
 355
 356       else
 357          if Discard_Names (First_Subtype (Ptyp))
 358            or else No (Lit_Strings (Root_Type (Ptyp)))
 359          then
 360             --  When pragma Discard_Names applies to the first subtype,
 361             --  then build (Pref'Pos)'Img.
 362
 363             Rewrite (N,
 364               Make_Attribute_Reference (Loc,
 365                 Prefix =>
 366                    Make_Attribute_Reference (Loc,
 367                      Prefix         => Pref,
 368                      Attribute_Name => Name_Pos,
 369                      Expressions    => New_List (Expr)),
 370                 Attribute_Name =>
 371                   Name_Img));
 372             Analyze_And_Resolve (N, Standard_String);
 373             return;
 374
 375          else
 376             --  Here for enumeration type case
 377
 378             Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
 379
 380             if Ttyp = Standard_Integer_8 then
 381                Imid := RE_Image_Enumeration_8;
 382             elsif Ttyp = Standard_Integer_16  then
 383                Imid := RE_Image_Enumeration_16;
 384             else
 385                Imid := RE_Image_Enumeration_32;
 386             end if;
 387
 388             --  Apply a validity check, since it is a bit drastic to get a
 389             --  completely junk image value for an invalid value.
 390
 391             if not Expr_Known_Valid (Expr) then
 392                Insert_Valid_Check (Expr);
 393             end if;
 394
 395             Enum_Case := True;
 396          end if;
 397       end if;
 398
 399       --  Build first argument for call
 400
 401       if Enum_Case then
 402          Arg_List := New_List (
 403            Make_Attribute_Reference (Loc,
 404              Attribute_Name => Name_Pos,
 405              Prefix         => New_Occurrence_Of (Ptyp, Loc),
 406              Expressions    => New_List (Expr)));
 407
 408       else
 409          Arg_List := New_List (Convert_To (Tent, Expr));
 410       end if;
 411
 412       --  Append Snn, Pnn arguments
 413
 414       Append_To (Arg_List, New_Occurrence_Of (Snn, Loc));
 415       Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc));
 416
 417       --  Get entity of procedure to call
 418
 419       Proc_Ent := RTE (Imid);
 420
 421       --  If the procedure entity is empty, that means we have a case in
 422       --  no run time mode where the operation is not allowed, and an
 423       --  appropriate diagnostic has already been issued.
 424
 425       if No (Proc_Ent) then
 426          return;
 427       end if;
 428
 429       --  Otherwise complete preparation of arguments for run-time call
 430
 431       --  Add extra arguments for Enumeration case
 432
 433       if Enum_Case then
 434          Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
 435          Append_To (Arg_List,
 436            Make_Attribute_Reference (Loc,
 437              Prefix         => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
 438              Attribute_Name => Name_Address));
 439
 440       --  For floating-point types, append Digits argument
 441
 442       elsif Is_Floating_Point_Type (Rtyp) then
 443          Append_To (Arg_List,
 444            Make_Attribute_Reference (Loc,
 445              Prefix         => New_Reference_To (Ptyp, Loc),
 446              Attribute_Name => Name_Digits));
 447
 448       --  For ordinary fixed-point types, append Aft parameter
 449
 450       elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
 451          Append_To (Arg_List,
 452            Make_Attribute_Reference (Loc,
 453              Prefix         => New_Reference_To (Ptyp, Loc),
 454              Attribute_Name => Name_Aft));
 455
 456       --  For decimal, append Scale and also set to do literal conversion
 457
 458       elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
 459          Append_To (Arg_List,
 460            Make_Attribute_Reference (Loc,
 461              Prefix => New_Reference_To (Ptyp, Loc),
 462              Attribute_Name => Name_Scale));
 463
 464          Set_Conversion_OK (First (Arg_List));
 465          Set_Etype (First (Arg_List), Tent);
 466
 467          --  For Wide_Character, append Ada 2005 indication
 468
 469       elsif Rtyp = Standard_Wide_Character then
 470          Append_To (Arg_List,
 471            New_Reference_To (Boolean_Literals (Ada_Version >= Ada_05), Loc));
 472       end if;
 473
 474       --  Now append the procedure call to the insert list
 475
 476       Append_To (Ins_List,
 477          Make_Procedure_Call_Statement (Loc,
 478           Name                   => New_Reference_To (Proc_Ent, Loc),
 479           Parameter_Associations => Arg_List));
 480
 481       --  Insert declarations of Snn, Pnn, and the procedure call. We suppress
 482       --  checks because we are sure that everything is in range at this stage.
 483
 484       Insert_Actions (N, Ins_List, Suppress => All_Checks);
 485
 486       --  Final step is to rewrite the expression as a slice and analyze,
 487       --  again with no checks, since we are sure that everything is OK.
 488
 489       Rewrite (N,
 490         Make_Slice (Loc,
 491           Prefix         => New_Occurrence_Of (Snn, Loc),
 492           Discrete_Range =>
 493             Make_Range (Loc,
 494               Low_Bound  => Make_Integer_Literal (Loc, 1),
 495               High_Bound => New_Occurrence_Of (Pnn, Loc))));
 496
 497       Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
 498    end Expand_Image_Attribute;
 499
 500    ----------------------------
 501    -- Expand_Value_Attribute --
 502    ----------------------------
 503
 504    --  For scalar types derived from Boolean, Character and integer types
 505    --  in package Standard, typ'Value (X) expands into:
 506
 507    --    btyp (Value_xx (X))
 508
 509    --  where btyp is he base type of the prefix
 510
 511    --    For types whose root type is Character
 512    --      xx = Character
 513
 514    --    For types whose root type is Wide_Character
 515    --      xx = Wide_Character
 516
 517    --    For types whose root type is Wide_Wide_Character
 518    --      xx = Wide_Wide_Character
 519
 520    --    For types whose root type is Boolean
 521    --      xx = Boolean
 522
 523    --    For signed integer types with size <= Integer'Size
 524    --      xx = Integer
 525
 526    --    For other signed integer types
 527    --      xx = Long_Long_Integer
 528
 529    --    For modular types with modulus <= System.Unsigned_Types.Unsigned
 530    --      xx = Unsigned
 531
 532    --    For other modular integer types
 533    --      xx = Long_Long_Unsigned
 534
 535    --    For floating-point types and ordinary fixed-point types
 536    --      xx = Real
 537
 538    --  For Wide_[Wide_]Character types, typ'Value (X) expands into:
 539
 540    --    btyp (Value_xx (X, EM))
 541
 542    --  where btyp is the base type of the prefix, and EM is the encoding method
 543
 544    --  For decimal types with size <= Integer'Size, typ'Value (X)
 545    --  expands into
 546
 547    --    btyp?(Value_Decimal (X, typ'Scale));
 548
 549    --  For all other decimal types, typ'Value (X) expands into
 550
 551    --    btyp?(Value_Long_Long_Decimal (X, typ'Scale))
 552
 553    --  For enumeration types other than those derived from types Boolean,
 554    --  Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
 555
 556    --    Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
 557
 558    --  where typS and typI and the Lit_Strings and Lit_Indexes entities
 559    --  from T's root type entity, and Num is Enum'Pos (Enum'Last). The
 560    --  Value_Enumeration_NN function will search the tables looking for
 561    --  X and return the position number in the table if found which is
 562    --  used to provide the result of 'Value (using Enum'Val). If the
 563    --  value is not found Constraint_Error is raised. The suffix _NN
 564    --  depends on the element type of typI.
 565
 566    procedure Expand_Value_Attribute (N : Node_Id) is
 567       Loc   : constant Source_Ptr := Sloc (N);
 568       Typ   : constant Entity_Id  := Etype (N);
 569       Btyp  : constant Entity_Id  := Base_Type (Typ);
 570       Rtyp  : constant Entity_Id  := Root_Type (Typ);
 571       Exprs : constant List_Id    := Expressions (N);
 572       Vid   : RE_Id;
 573       Args  : List_Id;
 574       Func  : RE_Id;
 575       Ttyp  : Entity_Id;
 576
 577    begin
 578       Args := Exprs;
 579
 580       if Rtyp = Standard_Character then
 581          Vid := RE_Value_Character;
 582
 583       elsif Rtyp = Standard_Boolean then
 584          Vid := RE_Value_Boolean;
 585
 586       elsif Rtyp = Standard_Wide_Character then
 587          Vid := RE_Value_Wide_Character;
 588
 589          Append_To (Args,
 590            Make_Integer_Literal (Loc,
 591              Intval => Int (Wide_Character_Encoding_Method)));
 592
 593       elsif Rtyp = Standard_Wide_Wide_Character then
 594          Vid := RE_Value_Wide_Wide_Character;
 595
 596          Append_To (Args,
 597            Make_Integer_Literal (Loc,
 598              Intval => Int (Wide_Character_Encoding_Method)));
 599
 600       elsif     Rtyp = Base_Type (Standard_Short_Short_Integer)
 601         or else Rtyp = Base_Type (Standard_Short_Integer)
 602         or else Rtyp = Base_Type (Standard_Integer)
 603       then
 604          Vid := RE_Value_Integer;
 605
 606       elsif Is_Signed_Integer_Type (Rtyp) then
 607          Vid := RE_Value_Long_Long_Integer;
 608
 609       elsif Is_Modular_Integer_Type (Rtyp) then
 610          if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
 611             Vid := RE_Value_Unsigned;
 612          else
 613             Vid := RE_Value_Long_Long_Unsigned;
 614          end if;
 615
 616       elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
 617          if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
 618             Vid := RE_Value_Decimal;
 619          else
 620             Vid := RE_Value_Long_Long_Decimal;
 621          end if;
 622
 623          Append_To (Args,
 624            Make_Attribute_Reference (Loc,
 625              Prefix => New_Reference_To (Typ, Loc),
 626              Attribute_Name => Name_Scale));
 627
 628          Rewrite (N,
 629            OK_Convert_To (Btyp,
 630              Make_Function_Call (Loc,
 631                Name => New_Reference_To (RTE (Vid), Loc),
 632                Parameter_Associations => Args)));
 633
 634          Set_Etype (N, Btyp);
 635          Analyze_And_Resolve (N, Btyp);
 636          return;
 637
 638       elsif Is_Real_Type (Rtyp) then
 639          Vid := RE_Value_Real;
 640
 641       --  Only other possibility is user defined enumeration type
 642
 643       else
 644          pragma Assert (Is_Enumeration_Type (Rtyp));
 645
 646          --  Case of pragma Discard_Names, transform the Value
 647          --  attribute to Btyp'Val (Long_Long_Integer'Value (Args))
 648
 649          if Discard_Names (First_Subtype (Typ))
 650            or else No (Lit_Strings (Rtyp))
 651          then
 652             Rewrite (N,
 653               Make_Attribute_Reference (Loc,
 654                 Prefix => New_Reference_To (Btyp, Loc),
 655                 Attribute_Name => Name_Val,
 656                 Expressions => New_List (
 657                   Make_Attribute_Reference (Loc,
 658                     Prefix =>
 659                       New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
 660                     Attribute_Name => Name_Value,
 661                     Expressions => Args))));
 662
 663             Analyze_And_Resolve (N, Btyp);
 664
 665          --  Here for normal case where we have enumeration tables, this
 666          --  is where we build
 667
 668          --    T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
 669
 670          else
 671             Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
 672
 673             if Ttyp = Standard_Integer_8 then
 674                Func := RE_Value_Enumeration_8;
 675             elsif Ttyp = Standard_Integer_16  then
 676                Func := RE_Value_Enumeration_16;
 677             else
 678                Func := RE_Value_Enumeration_32;
 679             end if;
 680
 681             Prepend_To (Args,
 682               Make_Attribute_Reference (Loc,
 683                 Prefix => New_Occurrence_Of (Rtyp, Loc),
 684                 Attribute_Name => Name_Pos,
 685                 Expressions => New_List (
 686                   Make_Attribute_Reference (Loc,
 687                     Prefix => New_Occurrence_Of (Rtyp, Loc),
 688                     Attribute_Name => Name_Last))));
 689
 690             Prepend_To (Args,
 691               Make_Attribute_Reference (Loc,
 692                 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
 693                 Attribute_Name => Name_Address));
 694
 695             Prepend_To (Args,
 696               New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
 697
 698             Rewrite (N,
 699               Make_Attribute_Reference (Loc,
 700                 Prefix => New_Reference_To (Typ, Loc),
 701                 Attribute_Name => Name_Val,
 702                 Expressions => New_List (
 703                   Make_Function_Call (Loc,
 704                     Name =>
 705                       New_Reference_To (RTE (Func), Loc),
 706                     Parameter_Associations => Args))));
 707
 708             Analyze_And_Resolve (N, Btyp);
 709          end if;
 710
 711          return;
 712       end if;
 713
 714       --  Fall through for all cases except user defined enumeration type
 715       --  and decimal types, with Vid set to the Id of the entity for the
 716       --  Value routine and Args set to the list of parameters for the call.
 717
 718       --  Compiling package Ada.Tags under No_Run_Time_Mode we disable the
 719       --  expansion of the attribute into the function call statement to avoid
 720       --  generating spurious errors caused by the use of Integer_Address'Value
 721       --  in our implementation of Ada.Tags.Internal_Tag
 722
 723       --  Seems like a bit of a kludge, there should be a better way ???
 724
 725       --  There is a better way, you should also test RTE_Available ???
 726
 727       if No_Run_Time_Mode
 728         and then Rtyp = RTE (RE_Integer_Address)
 729         and then RTU_Loaded (Ada_Tags)
 730         and then Cunit_Entity (Current_Sem_Unit)
 731                    = Body_Entity (RTU_Entity (Ada_Tags))
 732       then
 733          Rewrite (N,
 734            Unchecked_Convert_To (Rtyp,
 735              Make_Integer_Literal (Loc, Uint_0)));
 736       else
 737          Rewrite (N,
 738            Convert_To (Btyp,
 739              Make_Function_Call (Loc,
 740                Name => New_Reference_To (RTE (Vid), Loc),
 741                Parameter_Associations => Args)));
 742       end if;
 743
 744       Analyze_And_Resolve (N, Btyp);
 745    end Expand_Value_Attribute;
 746
 747    ---------------------------------
 748    -- Expand_Wide_Image_Attribute --
 749    ---------------------------------
 750
 751    --  We expand typ'Wide_Image (X) as follows. First we insert this code:
 752
 753    --    Rnn : Wide_String (1 .. rt'Wide_Width);
 754    --    Lnn : Natural;
 755    --    String_To_Wide_String
 756    --      (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
 757
 758    --  where rt is the root type of the prefix type
 759
 760    --  Now we replace the Wide_Image reference by
 761
 762    --    Rnn (1 .. Lnn)
 763
 764    --  This works in all cases because String_To_Wide_String converts any
 765    --  wide character escape sequences resulting from the Image call to the
 766    --  proper Wide_Character equivalent
 767
 768    --  not quite right for typ = Wide_Character ???
 769
 770    procedure Expand_Wide_Image_Attribute (N : Node_Id) is
 771       Loc  : constant Source_Ptr := Sloc (N);
 772       Rtyp : constant Entity_Id  := Root_Type (Entity (Prefix (N)));
 773
 774       Rnn : constant Entity_Id :=
 775               Make_Defining_Identifier (Loc,
 776                 Chars => New_Internal_Name ('S'));
 777
 778       Lnn : constant Entity_Id :=
 779               Make_Defining_Identifier (Loc,
 780                 Chars => New_Internal_Name ('P'));
 781
 782    begin
 783       Insert_Actions (N, New_List (
 784
 785          --  Rnn : Wide_String (1 .. base_typ'Width);
 786
 787          Make_Object_Declaration (Loc,
 788             Defining_Identifier => Rnn,
 789             Object_Definition   =>
 790               Make_Subtype_Indication (Loc,
 791                 Subtype_Mark =>
 792                   New_Occurrence_Of (Standard_Wide_String, Loc),
 793                 Constraint   =>
 794                   Make_Index_Or_Discriminant_Constraint (Loc,
 795                     Constraints => New_List (
 796                       Make_Range (Loc,
 797                         Low_Bound  => Make_Integer_Literal (Loc, 1),
 798                         High_Bound =>
 799                           Make_Attribute_Reference (Loc,
 800                             Prefix         => New_Occurrence_Of (Rtyp, Loc),
 801                             Attribute_Name => Name_Wide_Width)))))),
 802
 803          --  Lnn : Natural;
 804
 805          Make_Object_Declaration (Loc,
 806            Defining_Identifier => Lnn,
 807            Object_Definition   => New_Occurrence_Of (Standard_Natural, Loc)),
 808
 809          --    String_To_Wide_String
 810          --      (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
 811
 812          Make_Procedure_Call_Statement (Loc,
 813            Name =>
 814              New_Reference_To (RTE (RE_String_To_Wide_String), Loc),
 815
 816            Parameter_Associations => New_List (
 817              Make_Attribute_Reference (Loc,
 818                Prefix         => Prefix (N),
 819                Attribute_Name => Name_Image,
 820                Expressions    => Expressions (N)),
 821              New_Reference_To (Rnn, Loc),
 822              New_Reference_To (Lnn, Loc),
 823              Make_Integer_Literal (Loc,
 824                Intval => Int (Wide_Character_Encoding_Method))))),
 825
 826          --  Suppress checks because we know everything is properly in range
 827
 828          Suppress => All_Checks);
 829
 830       --  Final step is to rewrite the expression as a slice and analyze,
 831       --  again with no checks, since we are sure that everything is OK.
 832
 833       Rewrite (N,
 834         Make_Slice (Loc,
 835           Prefix         => New_Occurrence_Of (Rnn, Loc),
 836           Discrete_Range =>
 837             Make_Range (Loc,
 838               Low_Bound  => Make_Integer_Literal (Loc, 1),
 839               High_Bound => New_Occurrence_Of (Lnn, Loc))));
 840
 841       Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks);
 842    end Expand_Wide_Image_Attribute;
 843
 844    --------------------------------------
 845    -- Expand_Wide_Wide_Image_Attribute --
 846    --------------------------------------
 847
 848    --  We expand typ'Wide_Wide_Image (X) as follows. First we insert this code:
 849
 850    --    Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
 851    --    Lnn : Natural;
 852    --    String_To_Wide_Wide_String
 853    --      (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
 854
 855    --  where rt is the root type of the prefix type
 856
 857    --  Now we replace the Wide_Wide_Image reference by
 858
 859    --    Rnn (1 .. Lnn)
 860
 861    --  This works in all cases because String_To_Wide_Wide_String converts any
 862    --  wide character escape sequences resulting from the Image call to the
 863    --  proper Wide_Wide_Character equivalent
 864
 865    --  not quite right for typ = Wide_Wide_Character ???
 866
 867    procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is
 868       Loc  : constant Source_Ptr := Sloc (N);
 869       Rtyp : constant Entity_Id  := Root_Type (Entity (Prefix (N)));
 870
 871       Rnn : constant Entity_Id :=
 872               Make_Defining_Identifier (Loc,
 873                 Chars => New_Internal_Name ('S'));
 874
 875       Lnn : constant Entity_Id :=
 876               Make_Defining_Identifier (Loc,
 877                 Chars => New_Internal_Name ('P'));
 878
 879    begin
 880       Insert_Actions (N, New_List (
 881
 882          --  Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
 883
 884          Make_Object_Declaration (Loc,
 885             Defining_Identifier => Rnn,
 886             Object_Definition   =>
 887               Make_Subtype_Indication (Loc,
 888                 Subtype_Mark =>
 889                   New_Occurrence_Of (Standard_Wide_Wide_String, Loc),
 890                 Constraint   =>
 891                   Make_Index_Or_Discriminant_Constraint (Loc,
 892                     Constraints => New_List (
 893                       Make_Range (Loc,
 894                         Low_Bound  => Make_Integer_Literal (Loc, 1),
 895                         High_Bound =>
 896                           Make_Attribute_Reference (Loc,
 897                             Prefix         => New_Occurrence_Of (Rtyp, Loc),
 898                             Attribute_Name => Name_Wide_Wide_Width)))))),
 899
 900          --  Lnn : Natural;
 901
 902          Make_Object_Declaration (Loc,
 903            Defining_Identifier => Lnn,
 904            Object_Definition   => New_Occurrence_Of (Standard_Natural, Loc)),
 905
 906          --    String_To_Wide_Wide_String
 907          --      (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
 908
 909          Make_Procedure_Call_Statement (Loc,
 910            Name =>
 911              New_Reference_To (RTE (RE_String_To_Wide_Wide_String), Loc),
 912
 913            Parameter_Associations => New_List (
 914              Make_Attribute_Reference (Loc,
 915                Prefix         => Prefix (N),
 916                Attribute_Name => Name_Image,
 917                Expressions    => Expressions (N)),
 918              New_Reference_To (Rnn, Loc),
 919              New_Reference_To (Lnn, Loc),
 920              Make_Integer_Literal (Loc,
 921                Intval => Int (Wide_Character_Encoding_Method))))),
 922
 923          --  Suppress checks because we know everything is properly in range
 924
 925          Suppress => All_Checks);
 926
 927       --  Final step is to rewrite the expression as a slice and analyze,
 928       --  again with no checks, since we are sure that everything is OK.
 929
 930       Rewrite (N,
 931         Make_Slice (Loc,
 932           Prefix         => New_Occurrence_Of (Rnn, Loc),
 933           Discrete_Range =>
 934             Make_Range (Loc,
 935               Low_Bound  => Make_Integer_Literal (Loc, 1),
 936               High_Bound => New_Occurrence_Of (Lnn, Loc))));
 937
 938       Analyze_And_Resolve
 939         (N, Standard_Wide_Wide_String, Suppress => All_Checks);
 940    end Expand_Wide_Wide_Image_Attribute;
 941
 942    ----------------------------
 943    -- Expand_Width_Attribute --
 944    ----------------------------
 945
 946    --  The processing here also handles the case of Wide_[Wide_]Width. With the
 947    --  exceptions noted, the processing is identical
 948
 949    --  For scalar types derived from Boolean, character and integer types
 950    --  in package Standard. Note that the Width attribute is computed at
 951    --  compile time for all cases except those involving non-static sub-
 952    --  types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
 953
 954    --    Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
 955
 956    --  where
 957
 958    --    For types whose root type is Character
 959    --      xx = Width_Character
 960    --      yy = Character
 961
 962    --    For types whose root type is Wide_Character
 963    --      xx = Wide_Width_Character
 964    --      yy = Character
 965
 966    --    For types whose root type is Wide_Wide_Character
 967    --      xx = Wide_Wide_Width_Character
 968    --      yy = Character
 969
 970    --    For types whose root type is Boolean
 971    --      xx = Width_Boolean
 972    --      yy = Boolean
 973
 974    --    For signed integer types
 975    --      xx = Width_Long_Long_Integer
 976    --      yy = Long_Long_Integer
 977
 978    --    For modular integer types
 979    --      xx = Width_Long_Long_Unsigned
 980    --      yy = Long_Long_Unsigned
 981
 982    --  For types derived from Wide_Character, typ'Width expands into
 983
 984    --    Result_Type (Width_Wide_Character (
 985    --      Wide_Character (typ'First),
 986    --      Wide_Character (typ'Last),
 987
 988    --  and typ'Wide_Width expands into:
 989
 990    --    Result_Type (Wide_Width_Wide_Character (
 991    --      Wide_Character (typ'First),
 992    --      Wide_Character (typ'Last));
 993
 994    --  and typ'Wide_Wide_Width expands into
 995
 996    --    Result_Type (Wide_Wide_Width_Wide_Character (
 997    --      Wide_Character (typ'First),
 998    --      Wide_Character (typ'Last));
 999
1000    --  For types derived from Wide_Wide_Character, typ'Width expands into
1001
1002    --    Result_Type (Width_Wide_Wide_Character (
1003    --      Wide_Wide_Character (typ'First),
1004    --      Wide_Wide_Character (typ'Last),
1005
1006    --  and typ'Wide_Width expands into:
1007
1008    --    Result_Type (Wide_Width_Wide_Wide_Character (
1009    --      Wide_Wide_Character (typ'First),
1010    --      Wide_Wide_Character (typ'Last));
1011
1012    --  and typ'Wide_Wide_Width expands into
1013
1014    --    Result_Type (Wide_Wide_Width_Wide_Wide_Char (
1015    --      Wide_Wide_Character (typ'First),
1016    --      Wide_Wide_Character (typ'Last));
1017
1018    --  For real types, typ'Width and typ'Wide_[Wide_]Width expand into
1019
1020    --    if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
1021
1022    --  where btyp is the base type. This looks recursive but it isn't
1023    --  because the base type is always static, and hence the expression
1024    --  in the else is reduced to an integer literal.
1025
1026    --  For user defined enumeration types, typ'Width expands into
1027
1028    --    Result_Type (Width_Enumeration_NN
1029    --                  (typS,
1030    --                   typI'Address,
1031    --                   typ'Pos (typ'First),
1032    --                   typ'Pos (Typ'Last)));
1033
1034    --  and typ'Wide_Width expands into:
1035
1036    --    Result_Type (Wide_Width_Enumeration_NN
1037    --                  (typS,
1038    --                   typI,
1039    --                   typ'Pos (typ'First),
1040    --                   typ'Pos (Typ'Last))
1041    --                   Wide_Character_Encoding_Method);
1042
1043    --  and typ'Wide_Wide_Width expands into:
1044
1045    --    Result_Type (Wide_Wide_Width_Enumeration_NN
1046    --                  (typS,
1047    --                   typI,
1048    --                   typ'Pos (typ'First),
1049    --                   typ'Pos (Typ'Last))
1050    --                   Wide_Character_Encoding_Method);
1051
1052    --  where typS and typI are the enumeration image strings and
1053    --  indexes table, as described in Build_Enumeration_Image_Tables.
1054    --  NN is 8/16/32 for depending on the element type for typI.
1055
1056    procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is
1057       Loc     : constant Source_Ptr := Sloc (N);
1058       Typ     : constant Entity_Id  := Etype (N);
1059       Pref    : constant Node_Id    := Prefix (N);
1060       Ptyp    : constant Entity_Id  := Etype (Pref);
1061       Rtyp    : constant Entity_Id  := Root_Type (Ptyp);
1062       XX      : RE_Id;
1063       YY      : Entity_Id;
1064       Arglist : List_Id;
1065       Ttyp    : Entity_Id;
1066
1067    begin
1068       --  Types derived from Standard.Boolean
1069
1070       if Rtyp = Standard_Boolean then
1071          XX := RE_Width_Boolean;
1072          YY := Rtyp;
1073
1074       --  Types derived from Standard.Character
1075
1076       elsif Rtyp = Standard_Character then
1077          case Attr is
1078             when Normal    => XX := RE_Width_Character;
1079             when Wide      => XX := RE_Wide_Width_Character;
1080             when Wide_Wide => XX := RE_Wide_Wide_Width_Character;
1081          end case;
1082
1083          YY := Rtyp;
1084
1085       --  Types derived from Standard.Wide_Character
1086
1087       elsif Rtyp = Standard_Wide_Character then
1088          case Attr is
1089             when Normal    => XX := RE_Width_Wide_Character;
1090             when Wide      => XX := RE_Wide_Width_Wide_Character;
1091             when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character;
1092          end case;
1093
1094          YY := Rtyp;
1095
1096       --  Types derived from Standard.Wide_Wide_Character
1097
1098       elsif Rtyp = Standard_Wide_Wide_Character then
1099          case Attr is
1100             when Normal    => XX := RE_Width_Wide_Wide_Character;
1101             when Wide      => XX := RE_Wide_Width_Wide_Wide_Character;
1102             when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char;
1103          end case;
1104
1105          YY := Rtyp;
1106
1107       --  Signed integer types
1108
1109       elsif Is_Signed_Integer_Type (Rtyp) then
1110          XX := RE_Width_Long_Long_Integer;
1111          YY := Standard_Long_Long_Integer;
1112
1113       --  Modular integer types
1114
1115       elsif Is_Modular_Integer_Type (Rtyp) then
1116          XX := RE_Width_Long_Long_Unsigned;
1117          YY := RTE (RE_Long_Long_Unsigned);
1118
1119       --  Real types
1120
1121       elsif Is_Real_Type (Rtyp) then
1122
1123          Rewrite (N,
1124            Make_Conditional_Expression (Loc,
1125              Expressions => New_List (
1126
1127                Make_Op_Gt (Loc,
1128                  Left_Opnd =>
1129                    Make_Attribute_Reference (Loc,
1130                      Prefix => New_Reference_To (Ptyp, Loc),
1131                      Attribute_Name => Name_First),
1132
1133                  Right_Opnd =>
1134                    Make_Attribute_Reference (Loc,
1135                      Prefix => New_Reference_To (Ptyp, Loc),
1136                      Attribute_Name => Name_Last)),
1137
1138                Make_Integer_Literal (Loc, 0),
1139
1140                Make_Attribute_Reference (Loc,
1141                  Prefix => New_Reference_To (Base_Type (Ptyp), Loc),
1142                  Attribute_Name => Name_Width))));
1143
1144          Analyze_And_Resolve (N, Typ);
1145          return;
1146
1147       --  User defined enumeration types
1148
1149       else
1150          pragma Assert (Is_Enumeration_Type (Rtyp));
1151
1152          if Discard_Names (Rtyp) then
1153
1154             --  This is a configurable run-time, or else a restriction is in
1155             --  effect. In either case the attribute cannot be supported. Force
1156             --  a load error from Rtsfind to generate an appropriate message,
1157             --  as is done with other ZFP violations.
1158
1159             declare
1160                pragma Warnings (Off); -- since Discard is unreferenced
1161                Discard : constant Entity_Id := RTE (RE_Null);
1162                pragma Warnings (On);
1163             begin
1164                return;
1165             end;
1166          end if;
1167
1168          Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1169
1170          case Attr is
1171             when Normal =>
1172                if Ttyp = Standard_Integer_8 then
1173                   XX := RE_Width_Enumeration_8;
1174                elsif Ttyp = Standard_Integer_16  then
1175                   XX := RE_Width_Enumeration_16;
1176                else
1177                   XX := RE_Width_Enumeration_32;
1178                end if;
1179
1180             when Wide =>
1181                if Ttyp = Standard_Integer_8 then
1182                   XX := RE_Wide_Width_Enumeration_8;
1183                elsif Ttyp = Standard_Integer_16  then
1184                   XX := RE_Wide_Width_Enumeration_16;
1185                else
1186                   XX := RE_Wide_Width_Enumeration_32;
1187                end if;
1188
1189             when Wide_Wide =>
1190                if Ttyp = Standard_Integer_8 then
1191                   XX := RE_Wide_Wide_Width_Enumeration_8;
1192                elsif Ttyp = Standard_Integer_16  then
1193                   XX := RE_Wide_Wide_Width_Enumeration_16;
1194                else
1195                   XX := RE_Wide_Wide_Width_Enumeration_32;
1196                end if;
1197          end case;
1198
1199          Arglist :=
1200            New_List (
1201              New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
1202
1203              Make_Attribute_Reference (Loc,
1204                Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1205                Attribute_Name => Name_Address),
1206
1207              Make_Attribute_Reference (Loc,
1208                Prefix => New_Reference_To (Ptyp, Loc),
1209                Attribute_Name => Name_Pos,
1210
1211                Expressions => New_List (
1212                  Make_Attribute_Reference (Loc,
1213                    Prefix => New_Reference_To (Ptyp, Loc),
1214                    Attribute_Name => Name_First))),
1215
1216              Make_Attribute_Reference (Loc,
1217                Prefix => New_Reference_To (Ptyp, Loc),
1218                Attribute_Name => Name_Pos,
1219
1220                Expressions => New_List (
1221                  Make_Attribute_Reference (Loc,
1222                    Prefix => New_Reference_To (Ptyp, Loc),
1223                    Attribute_Name => Name_Last))));
1224
1225          Rewrite (N,
1226            Convert_To (Typ,
1227              Make_Function_Call (Loc,
1228                Name => New_Reference_To (RTE (XX), Loc),
1229                Parameter_Associations => Arglist)));
1230
1231          Analyze_And_Resolve (N, Typ);
1232          return;
1233       end if;
1234
1235       --  If we fall through XX and YY are set
1236
1237       Arglist := New_List (
1238         Convert_To (YY,
1239           Make_Attribute_Reference (Loc,
1240             Prefix => New_Reference_To (Ptyp, Loc),
1241             Attribute_Name => Name_First)),
1242
1243         Convert_To (YY,
1244           Make_Attribute_Reference (Loc,
1245             Prefix => New_Reference_To (Ptyp, Loc),
1246             Attribute_Name => Name_Last)));
1247
1248       Rewrite (N,
1249         Convert_To (Typ,
1250           Make_Function_Call (Loc,
1251             Name => New_Reference_To (RTE (XX), Loc),
1252             Parameter_Associations => Arglist)));
1253
1254       Analyze_And_Resolve (N, Typ);
1255    end Expand_Width_Attribute;
1256
1257 end Exp_Imgv;