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-2023, 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 Einfo.Entities; use Einfo.Entities;
  31 with Einfo.Utils;    use Einfo.Utils;
  32 with Debug;          use Debug;
  33 with Exp_Put_Image;
  34 with Exp_Util;       use Exp_Util;
  35 with Lib;            use Lib;
  36 with Namet;          use Namet;
  37 with Nmake;          use Nmake;
  38 with Nlists;         use Nlists;
  39 with Opt;            use Opt;
  40 with Restrict;       use Restrict;
  41 with Rident;         use Rident;
  42 with Rtsfind;        use Rtsfind;
  43 with Sem_Aux;        use Sem_Aux;
  44 with Sem_Res;        use Sem_Res;
  45 with Sem_Util;       use Sem_Util;
  46 with Sinfo;          use Sinfo;
  47 with Sinfo.Nodes;    use Sinfo.Nodes;
  48 with Sinfo.Utils;    use Sinfo.Utils;
  49 with Snames;         use Snames;
  50 with Stand;          use Stand;
  51 with Stringt;        use Stringt;
  52 with Targparm;       use Targparm;
  53 with Tbuild;         use Tbuild;
  54 with Ttypes;         use Ttypes;
  55 with Uintp;          use Uintp;
  56 with Urealp;         use Urealp;
  57
  58 with System.Perfect_Hash_Generators;
  59
  60 package body Exp_Imgv is
  61
  62    procedure Rewrite_Object_Image
  63      (N         : Node_Id;
  64       Pref      : Node_Id;
  65       Attr_Name : Name_Id;
  66       Str_Typ   : Entity_Id);
  67    --  AI12-0124: Rewrite attribute 'Image when it is applied to an object
  68    --  reference as an attribute applied to a type. N denotes the node to be
  69    --  rewritten, Pref denotes the prefix of the 'Image attribute, and Name
  70    --  and Str_Typ specify which specific string type and 'Image attribute to
  71    --  apply (e.g. Name_Wide_Image and Standard_Wide_String).
  72
  73    ------------------------------------
  74    -- Build_Enumeration_Image_Tables --
  75    ------------------------------------
  76
  77    procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is
  78       Loc          : constant Source_Ptr := Sloc (E);
  79       In_Main_Unit : constant Boolean    := In_Extended_Main_Code_Unit (Loc);
  80
  81       Act  : List_Id;
  82       Eind : Entity_Id;
  83       Estr : Entity_Id;
  84       H_Id : Entity_Id;
  85       H_OK : Boolean;
  86       H_Sp : Node_Id;
  87       Ind  : List_Id;
  88       Ityp : Node_Id;
  89       Len  : Nat;
  90       Lit  : Entity_Id;
  91       Nlit : Nat;
  92       S_Id : Entity_Id;
  93       S_N  : Nat := 0;
  94       Str  : String_Id;
  95
  96       package SPHG renames System.Perfect_Hash_Generators;
  97
  98       Saved_SSO : constant Character := Opt.Default_SSO;
  99       --  Used to save the current scalar storage order during the generation
 100       --  of the literal lookup table.
 101
 102       Serial_Number_Budget : constant := 50;
 103       --  We may want to compute a perfect hash function for use by the Value
 104       --  attribute. However computing this function is costly and, therefore,
 105       --  cannot be done when compiling every unit where the enumeration type
 106       --  is referenced, so we do it only when compiling the unit where it is
 107       --  declared. This means that we may need to control the internal serial
 108       --  numbers of this unit, or else we would risk generating public symbols
 109       --  with mismatched names later on. The strategy for this is to allocate
 110       --  a fixed budget of serial numbers to be spent from a specified point
 111       --  until the end of the processing and to make sure that it is always
 112       --  exactly spent on all possible paths from this point.
 113
 114       Threshold : constant Nat :=
 115         (if Is_Library_Level_Entity (E)
 116            or else not Always_Compatible_Rep_On_Target
 117          then 3
 118          else Nat'Last);
 119       --  Threshold above which we want to generate the hash function in the
 120       --  default case. We avoid doing it if this would cause a trampoline to
 121       --  be generated because the type is local and descriptors are not used.
 122
 123       Threshold_For_Size : constant Nat := Nat'Max (Threshold, 9);
 124       --  But the function and its tables take a bit of space so the threshold
 125       --  is raised when compiling for size.
 126
 127       procedure Append_Table_To
 128         (L    : List_Id;
 129          E    : Entity_Id;
 130          UB   : Nat;
 131          Ctyp : Entity_Id;
 132          V    : List_Id);
 133       --  Append to L the declaration of E as a constant array of range 0 .. UB
 134       --  and component type Ctyp with initial value V.
 135
 136       ---------------------
 137       -- Append_Table_To --
 138       ---------------------
 139
 140       procedure Append_Table_To
 141         (L    : List_Id;
 142          E    : Entity_Id;
 143          UB   : Nat;
 144          Ctyp : Entity_Id;
 145          V    : List_Id)
 146       is
 147       begin
 148          Append_To (L,
 149            Make_Object_Declaration (Loc,
 150              Defining_Identifier => E,
 151              Constant_Present    => True,
 152              Object_Definition   =>
 153                Make_Constrained_Array_Definition (Loc,
 154                  Discrete_Subtype_Definitions => New_List (
 155                    Make_Range (Loc,
 156                      Low_Bound  => Make_Integer_Literal (Loc, 0),
 157                      High_Bound => Make_Integer_Literal (Loc, UB))),
 158                  Component_Definition =>
 159                    Make_Component_Definition (Loc,
 160                      Aliased_Present    => False,
 161                      Subtype_Indication => New_Occurrence_Of (Ctyp, Loc))),
 162              Expression          => Make_Aggregate (Loc, Expressions => V,
 163                                       Is_Enum_Array_Aggregate => True)));
 164       end Append_Table_To;
 165
 166    --  Start of Build_Enumeration_Image_Tables
 167
 168    begin
 169       --  Nothing to do for types other than a root enumeration type
 170
 171       if E /= Root_Type (E) then
 172          return;
 173
 174       --  Nothing to do if pragma Discard_Names applies
 175
 176       elsif Discard_Names (E) then
 177          return;
 178       end if;
 179
 180       --  Otherwise tables need constructing
 181
 182       Start_String;
 183       Ind := New_List;
 184       Lit := First_Literal (E);
 185       Len := 1;
 186       Nlit := 0;
 187       H_OK := False;
 188
 189       loop
 190          Append_To (Ind, Make_Integer_Literal (Loc, UI_From_Int (Len)));
 191
 192          exit when No (Lit);
 193          Nlit := Nlit + 1;
 194
 195          Get_Unqualified_Decoded_Name_String (Chars (Lit));
 196
 197          if Name_Buffer (1) /= ''' then
 198             Set_Casing (All_Upper_Case);
 199          end if;
 200
 201          Store_String_Chars (Name_Buffer (1 .. Name_Len));
 202          if In_Main_Unit then
 203             SPHG.Insert (Name_Buffer (1 .. Name_Len));
 204          end if;
 205          Len := Len + Int (Name_Len);
 206          Next_Literal (Lit);
 207       end loop;
 208
 209       if Len < Int (2 ** (8 - 1)) then
 210          Ityp := Standard_Integer_8;
 211       elsif Len < Int (2 ** (16 - 1)) then
 212          Ityp := Standard_Integer_16;
 213       else
 214          Ityp := Standard_Integer_32;
 215       end if;
 216
 217       Str := End_String;
 218
 219       Estr :=
 220         Make_Defining_Identifier (Loc,
 221           Chars => New_External_Name (Chars (E), 'S'));
 222
 223       Eind :=
 224         Make_Defining_Identifier (Loc,
 225           Chars => New_External_Name (Chars (E), 'N'));
 226
 227       Set_Lit_Strings (E, Estr);
 228       Set_Lit_Indexes (E, Eind);
 229
 230       --  Temporarily set the current scalar storage order to the default
 231       --  during the generation of the literals table, since both the Image and
 232       --  Value attributes rely on runtime routines for interpreting table
 233       --  values.
 234
 235       Opt.Default_SSO := ' ';
 236
 237       --  Generate literal table
 238
 239       Act :=
 240         New_List (
 241           Make_Object_Declaration (Loc,
 242             Defining_Identifier => Estr,
 243             Constant_Present    => True,
 244             Object_Definition   =>
 245               New_Occurrence_Of (Standard_String, Loc),
 246             Expression          =>
 247               Make_String_Literal (Loc,
 248                 Strval => Str)));
 249
 250       --  Generate index table
 251
 252       Append_Table_To (Act, Eind, Nlit, Ityp, Ind);
 253
 254       --  If the number of literals is not greater than Threshold, then we are
 255       --  done. Otherwise we generate a (perfect) hash function for use by the
 256       --  Value attribute.
 257
 258       if Nlit > Threshold then
 259          --  We start to count serial numbers from here
 260
 261          S_N := Increment_Serial_Number;
 262
 263          --  Generate specification of hash function
 264
 265          H_Id :=
 266            Make_Defining_Identifier (Loc,
 267              Chars => New_External_Name (Chars (E), 'H'));
 268          Mutate_Ekind    (H_Id, E_Function);
 269          Set_Is_Internal (H_Id);
 270
 271          if not Debug_Generated_Code then
 272             Set_Debug_Info_Off (H_Id);
 273          end if;
 274
 275          Set_Lit_Hash (E, H_Id);
 276
 277          S_Id := Make_Temporary (Loc, 'S');
 278
 279          H_Sp := Make_Function_Specification (Loc,
 280            Defining_Unit_Name       => H_Id,
 281            Parameter_Specifications => New_List (
 282              Make_Parameter_Specification (Loc,
 283                Defining_Identifier => S_Id,
 284                Parameter_Type      =>
 285                  New_Occurrence_Of (Standard_String, Loc))),
 286            Result_Definition       =>
 287              New_Occurrence_Of (Standard_Natural, Loc));
 288
 289          --  If the unit where the type is declared is the main unit, and the
 290          --  number of literals is greater than Threshold_For_Size when we are
 291          --  optimizing for size, and the restriction No_Implicit_Loops is not
 292          --  active, and -gnatd_h is not specified, and not GNAT_Mode, generate
 293          --  the hash function.
 294
 295          if In_Main_Unit
 296            and then (Optimize_Size = 0 or else Nlit > Threshold_For_Size)
 297            and then not Restriction_Active (No_Implicit_Loops)
 298            and then not Debug_Flag_Underscore_H
 299            and then not GNAT_Mode
 300          then
 301             declare
 302                LB : constant Positive := 2 * Positive (Nlit) + 1;
 303                UB : constant Positive := LB + 24;
 304
 305             begin
 306                --  Try at most 25 * 4 times to compute the hash function before
 307                --  giving up and using a linear search for the Value attribute.
 308
 309                for V in LB .. UB loop
 310                   begin
 311                      SPHG.Initialize (4321, V, SPHG.Memory_Space, Tries => 4);
 312                      SPHG.Compute ("");
 313                      H_OK := True;
 314                      exit;
 315                   exception
 316                      when SPHG.Too_Many_Tries => null;
 317                   end;
 318                end loop;
 319             end;
 320          end if;
 321
 322          --  If the hash function has been successfully computed, 4 more tables
 323          --  named P, T1, T2 and G are needed. The hash function is of the form
 324
 325          --     function Hash (S : String) return Natural is
 326          --        xxxP  : constant array (0 .. X) of Natural    = [...];
 327          --        xxxT1 : constant array (0 .. Y) of Index_Type = [...];
 328          --        xxxT2 : constant array (0 .. Y) of Index_Type = [...];
 329          --        xxxG  : constant array (0 .. Z) of Index_Type = [...];
 330
 331          --        F    : constant Natural := S'First - 1;
 332          --        L    : constant Natural := S'Length;
 333          --        A, B : Natural := 0;
 334          --        J    : Natural;
 335
 336          --     begin
 337          --        for K in P'Range loop
 338          --           exit when L < P (K);
 339          --           J := Character'Pos (S (P (K) + F));
 340          --           A := (A + Natural (T1 (K) * J)) mod N;
 341          --           B := (B + Natural (T2 (K) * J)) mod N;
 342          --        end loop;
 343
 344          --        return (Natural (G (A)) + Natural (G (B))) mod M;
 345          --     end Hash;
 346
 347          --  where N is the length of G and M the number of literals. Note that
 348          --  we declare the tables inside the function for two reasons: first,
 349          --  their analysis creates array subtypes and thus their concatenation
 350          --  operators which are homonyms of the concatenation operator and may
 351          --  change the homonym number of user operators declared in the scope;
 352          --  second, the code generator can fold the values in the tables when
 353          --  they are small and avoid emitting them in the final object code.
 354
 355          if H_OK then
 356             declare
 357                Siz, L1, L2 : Natural;
 358                I           : Int;
 359
 360                Pos,  T1,  T2,  G  : List_Id;
 361                EPos, ET1, ET2, EG : Entity_Id;
 362
 363                F, L, A, B, J, K : Entity_Id;
 364                Body_Decls       : List_Id;
 365                Body_Stmts       : List_Id;
 366                Loop_Stmts       : List_Id;
 367
 368             begin
 369                Body_Decls := New_List;
 370
 371                --  Generate position table
 372
 373                SPHG.Define (SPHG.Character_Position, Siz, L1, L2);
 374                Pos := New_List;
 375                for J in 0 .. L1 - 1 loop
 376                   I := Int (SPHG.Value (SPHG.Character_Position, J));
 377                   Append_To (Pos, Make_Integer_Literal (Loc, UI_From_Int (I)));
 378                end loop;
 379
 380                EPos :=
 381                  Make_Defining_Identifier (Loc,
 382                    Chars => New_External_Name (Chars (E), 'P'));
 383
 384                Append_Table_To
 385                  (Body_Decls, EPos, Nat (L1 - 1), Standard_Natural, Pos);
 386
 387                --  Generate function table 1
 388
 389                SPHG.Define (SPHG.Function_Table_1, Siz, L1, L2);
 390                T1 := New_List;
 391                for J in 0 .. L1 - 1 loop
 392                   I := Int (SPHG.Value (SPHG.Function_Table_1, J));
 393                   Append_To (T1, Make_Integer_Literal (Loc, UI_From_Int (I)));
 394                end loop;
 395
 396                ET1 :=
 397                  Make_Defining_Identifier (Loc,
 398                    Chars => New_External_Name (Chars (E), "T1"));
 399
 400                Ityp :=
 401                  Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True);
 402                Append_Table_To (Body_Decls, ET1, Nat (L1 - 1), Ityp, T1);
 403
 404                --  Generate function table 2
 405
 406                SPHG.Define (SPHG.Function_Table_2, Siz, L1, L2);
 407                T2 := New_List;
 408                for J in 0 .. L1 - 1 loop
 409                   I := Int (SPHG.Value (SPHG.Function_Table_2, J));
 410                   Append_To (T2, Make_Integer_Literal (Loc, UI_From_Int (I)));
 411                end loop;
 412
 413                ET2 :=
 414                  Make_Defining_Identifier (Loc,
 415                    Chars => New_External_Name (Chars (E), "T2"));
 416
 417                Ityp :=
 418                  Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True);
 419                Append_Table_To (Body_Decls, ET2, Nat (L1 - 1), Ityp, T2);
 420
 421                --  Generate graph table
 422
 423                SPHG.Define (SPHG.Graph_Table, Siz, L1, L2);
 424                G := New_List;
 425                for J in 0 .. L1 - 1 loop
 426                   I := Int (SPHG.Value (SPHG.Graph_Table, J));
 427                   Append_To (G, Make_Integer_Literal (Loc, UI_From_Int (I)));
 428                end loop;
 429
 430                EG :=
 431                  Make_Defining_Identifier (Loc,
 432                    Chars => New_External_Name (Chars (E), 'G'));
 433
 434                Ityp :=
 435                  Small_Integer_Type_For (UI_From_Int (Int (Siz)), Uns => True);
 436                Append_Table_To (Body_Decls, EG, Nat (L1 - 1), Ityp, G);
 437
 438                F := Make_Temporary (Loc, 'F');
 439
 440                Append_To (Body_Decls,
 441                  Make_Object_Declaration (Loc,
 442                    Defining_Identifier => F,
 443                    Object_Definition   =>
 444                      New_Occurrence_Of (Standard_Natural, Loc),
 445                    Expression          =>
 446                      Make_Op_Subtract (Loc,
 447                        Left_Opnd  =>
 448                          Make_Attribute_Reference (Loc,
 449                            Prefix => New_Occurrence_Of (S_Id, Loc),
 450                            Attribute_Name => Name_First),
 451                        Right_Opnd =>
 452                          Make_Integer_Literal (Loc, 1))));
 453
 454                L := Make_Temporary (Loc, 'L');
 455
 456                Append_To (Body_Decls,
 457                  Make_Object_Declaration (Loc,
 458                    Defining_Identifier => L,
 459                    Object_Definition   =>
 460                      New_Occurrence_Of (Standard_Natural, Loc),
 461                    Expression          =>
 462                      Make_Attribute_Reference (Loc,
 463                        Prefix         => New_Occurrence_Of (S_Id, Loc),
 464                        Attribute_Name => Name_Length)));
 465
 466                A := Make_Temporary (Loc, 'A');
 467
 468                Append_To (Body_Decls,
 469                  Make_Object_Declaration (Loc,
 470                    Defining_Identifier => A,
 471                    Object_Definition   =>
 472                      New_Occurrence_Of (Standard_Natural, Loc),
 473                    Expression          => Make_Integer_Literal (Loc, 0)));
 474
 475                B := Make_Temporary (Loc, 'B');
 476
 477                Append_To (Body_Decls,
 478                  Make_Object_Declaration (Loc,
 479                    Defining_Identifier => B,
 480                    Object_Definition   =>
 481                      New_Occurrence_Of (Standard_Natural, Loc),
 482                    Expression          => Make_Integer_Literal (Loc, 0)));
 483
 484                J := Make_Temporary (Loc, 'J');
 485
 486                Append_To (Body_Decls,
 487                  Make_Object_Declaration (Loc,
 488                    Defining_Identifier => J,
 489                    Object_Definition   =>
 490                      New_Occurrence_Of (Standard_Natural, Loc)));
 491
 492                K := Make_Temporary (Loc, 'K');
 493
 494                --  Generate exit when L < P (K);
 495
 496                Loop_Stmts := New_List (
 497                  Make_Exit_Statement (Loc,
 498                    Condition =>
 499                      Make_Op_Lt (Loc,
 500                        Left_Opnd  => New_Occurrence_Of (L, Loc),
 501                        Right_Opnd =>
 502                          Make_Indexed_Component (Loc,
 503                            Prefix      => New_Occurrence_Of (EPos, Loc),
 504                            Expressions => New_List (
 505                              New_Occurrence_Of (K, Loc))))));
 506
 507                --  Generate J := Character'Pos (S (P (K) + F));
 508
 509                Append_To (Loop_Stmts,
 510                  Make_Assignment_Statement (Loc,
 511                    Name       => New_Occurrence_Of (J, Loc),
 512                    Expression =>
 513                      Make_Attribute_Reference (Loc,
 514                        Prefix         =>
 515                          New_Occurrence_Of (Standard_Character, Loc),
 516                        Attribute_Name => Name_Pos,
 517                        Expressions    => New_List (
 518                          Make_Indexed_Component (Loc,
 519                            Prefix      => New_Occurrence_Of (S_Id, Loc),
 520                            Expressions => New_List (
 521                               Make_Op_Add (Loc,
 522                                 Left_Opnd  =>
 523                                   Make_Indexed_Component (Loc,
 524                                     Prefix      =>
 525                                       New_Occurrence_Of (EPos, Loc),
 526                                   Expressions => New_List (
 527                                     New_Occurrence_Of (K, Loc))),
 528                                 Right_Opnd =>
 529                                   New_Occurrence_Of (F, Loc))))))));
 530
 531                --  Generate A := (A + Natural (T1 (K) * J)) mod N;
 532
 533                Append_To (Loop_Stmts,
 534                  Make_Assignment_Statement (Loc,
 535                    Name       => New_Occurrence_Of (A, Loc),
 536                    Expression =>
 537                      Make_Op_Mod (Loc,
 538                        Left_Opnd  =>
 539                           Make_Op_Add (Loc,
 540                             Left_Opnd  => New_Occurrence_Of (A, Loc),
 541                             Right_Opnd =>
 542                               Make_Op_Multiply (Loc,
 543                                 Left_Opnd  =>
 544                                   Convert_To (Standard_Natural,
 545                                      Make_Indexed_Component (Loc,
 546                                        Prefix      =>
 547                                          New_Occurrence_Of (ET1, Loc),
 548                                        Expressions => New_List (
 549                                          New_Occurrence_Of (K, Loc)))),
 550                                 Right_Opnd => New_Occurrence_Of (J, Loc))),
 551                        Right_Opnd => Make_Integer_Literal (Loc, Int (L1)))));
 552
 553                --  Generate B := (B + Natural (T2 (K) * J)) mod N;
 554
 555                Append_To (Loop_Stmts,
 556                  Make_Assignment_Statement (Loc,
 557                    Name       => New_Occurrence_Of (B, Loc),
 558                    Expression =>
 559                      Make_Op_Mod (Loc,
 560                        Left_Opnd  =>
 561                           Make_Op_Add (Loc,
 562                             Left_Opnd  => New_Occurrence_Of (B, Loc),
 563                             Right_Opnd =>
 564                               Make_Op_Multiply (Loc,
 565                                 Left_Opnd  =>
 566                                   Convert_To (Standard_Natural,
 567                                      Make_Indexed_Component (Loc,
 568                                        Prefix      =>
 569                                          New_Occurrence_Of (ET2, Loc),
 570                                        Expressions => New_List (
 571                                          New_Occurrence_Of (K, Loc)))),
 572                                 Right_Opnd => New_Occurrence_Of (J, Loc))),
 573                        Right_Opnd => Make_Integer_Literal (Loc, Int (L1)))));
 574
 575             --  Generate loop
 576
 577                Body_Stmts := New_List (
 578                  Make_Implicit_Loop_Statement (N,
 579                    Iteration_Scheme =>
 580                      Make_Iteration_Scheme (Loc,
 581                        Loop_Parameter_Specification =>
 582                          Make_Loop_Parameter_Specification (Loc,
 583                            Defining_Identifier         => K,
 584                            Discrete_Subtype_Definition =>
 585                              Make_Attribute_Reference (Loc,
 586                                Prefix         =>
 587                                  New_Occurrence_Of (EPos, Loc),
 588                                Attribute_Name => Name_Range))),
 589                    Statements       => Loop_Stmts));
 590
 591                --  Generate return (Natural (G (A)) + Natural (G (B))) mod M;
 592
 593                Append_To (Body_Stmts,
 594                  Make_Simple_Return_Statement (Loc,
 595                    Expression =>
 596                      Make_Op_Mod (Loc,
 597                        Left_Opnd  =>
 598                          Make_Op_Add (Loc,
 599                            Left_Opnd  =>
 600                              Convert_To (Standard_Natural,
 601                                Make_Indexed_Component (Loc,
 602                                  Prefix      =>
 603                                    New_Occurrence_Of (EG, Loc),
 604                                  Expressions => New_List (
 605                                    New_Occurrence_Of (A, Loc)))),
 606                            Right_Opnd =>
 607                              Convert_To (Standard_Natural,
 608                                Make_Indexed_Component (Loc,
 609                                  Prefix      =>
 610                                    New_Occurrence_Of (EG, Loc),
 611                                  Expressions => New_List (
 612                                    New_Occurrence_Of (B, Loc))))),
 613                        Right_Opnd => Make_Integer_Literal (Loc, Nlit))));
 614
 615                --  Generate final body
 616
 617                Append_To (Act,
 618                  Make_Subprogram_Body (Loc,
 619                    Specification => H_Sp,
 620                    Declarations => Body_Decls,
 621                    Handled_Statement_Sequence =>
 622                      Make_Handled_Sequence_Of_Statements (Loc, Body_Stmts)));
 623             end;
 624
 625          --  If we chose not to or did not manage to compute the hash function,
 626          --  we need to build a dummy function always returning Natural'Last
 627          --  because other units reference it if they use the Value attribute.
 628
 629          elsif In_Main_Unit then
 630             declare
 631                Body_Stmts : List_Id;
 632
 633             begin
 634                --  Generate return Natural'Last
 635
 636                Body_Stmts := New_List (
 637                  Make_Simple_Return_Statement (Loc,
 638                    Expression =>
 639                      Make_Attribute_Reference (Loc,
 640                        Prefix         =>
 641                          New_Occurrence_Of (Standard_Natural, Loc),
 642                        Attribute_Name => Name_Last)));
 643
 644                --  Generate body
 645
 646                Append_To (Act,
 647                  Make_Subprogram_Body (Loc,
 648                    Specification => H_Sp,
 649                    Declarations => Empty_List,
 650                    Handled_Statement_Sequence =>
 651                      Make_Handled_Sequence_Of_Statements (Loc, Body_Stmts)));
 652             end;
 653
 654          --  For the other units, just declare the function
 655
 656          else
 657             Append_To (Act,
 658               Make_Subprogram_Declaration (Loc, Specification => H_Sp));
 659          end if;
 660
 661       else
 662          Set_Lit_Hash (E, Empty);
 663       end if;
 664
 665       if In_Main_Unit then
 666          System.Perfect_Hash_Generators.Finalize;
 667       end if;
 668
 669       Insert_Actions (N, Act, Suppress => All_Checks);
 670
 671       --  This is where we check that our budget of serial numbers has been
 672       --  entirely spent, see the declaration of Serial_Number_Budget above.
 673
 674       if Nlit > Threshold then
 675          Synchronize_Serial_Number (S_N + Serial_Number_Budget);
 676       end if;
 677
 678       --  Reset the scalar storage order to the saved value
 679
 680       Opt.Default_SSO := Saved_SSO;
 681    end Build_Enumeration_Image_Tables;
 682
 683    ----------------------------
 684    -- Expand_Image_Attribute --
 685    ----------------------------
 686
 687    --  For all cases other than user-defined enumeration types, the scheme
 688    --  is as follows. First we insert the following code:
 689
 690    --    Snn : String (1 .. rt'Width);
 691    --    Pnn : Natural;
 692    --    Image_xx (tv, Snn, Pnn [,pm]);
 693    --
 694    --  and then Expr is replaced by Snn (1 .. Pnn)
 695
 696    --  In the above expansion:
 697
 698    --    rt is the root type of the expression
 699    --    tv is the expression with the value, usually a type conversion
 700    --    pm is an extra parameter present in some cases
 701
 702    --  The following table shows tv, xx, and (if used) pm for the various
 703    --  possible types of the argument:
 704
 705    --    For types whose root type is Character
 706    --      xx = Character
 707    --      tv = Character (Expr)
 708
 709    --    For types whose root type is Boolean
 710    --      xx = Boolean
 711    --      tv = Boolean (Expr)
 712
 713    --    For signed integer types
 714    --      xx = [Long_Long_[Long_]]Integer
 715    --      tv = [Long_Long_[Long_]]Integer (Expr)
 716
 717    --    For modular types
 718    --      xx = [Long_Long_[Long_]]Unsigned
 719    --      tv = System.Unsigned_Types.[Long_Long_[Long_]]Unsigned (Expr)
 720
 721    --    For types whose root type is Wide_Character
 722    --      xx = Wide_Character
 723    --      tv = Wide_Character (Expr)
 724    --      pm = Boolean, true if Ada 2005 mode, False otherwise
 725
 726    --    For types whose root type is Wide_Wide_Character
 727    --      xx = Wide_Wide_Character
 728    --      tv = Wide_Wide_Character (Expr)
 729
 730    --    For floating-point types
 731    --      xx = Floating_Point
 732    --      tv = [Long_[Long_]]Float (Expr)
 733    --      pm = typ'Digits (typ = subtype of expression)
 734
 735    --    For decimal fixed-point types
 736    --      xx = Decimal{32,64,128}
 737    --      tv = Integer_{32,64,128} (Expr)? [convert with no scaling]
 738    --      pm = typ'Scale (typ = subtype of expression)
 739
 740    --    For the most common ordinary fixed-point types
 741    --      xx = Fixed{32,64,128}
 742    --      tv = Integer_{32,64,128} (Expr) [convert with no scaling]
 743    --      pm = numerator of typ'Small (typ = subtype of expression)
 744    --           denominator of typ'Small
 745    --           (Integer_{32,64,128} x typ'Small)'Fore
 746    --           typ'Aft
 747
 748    --    For other ordinary fixed-point types
 749    --      xx = Fixed
 750    --      tv = Long_Float (Expr)
 751    --      pm = typ'Aft (typ = subtype of expression)
 752
 753    --  For enumeration types other than those declared in package Standard
 754    --  or System, Snn, Pnn, are expanded as above, but the call looks like:
 755
 756    --    Image_Enumeration_NN (rt'Pos (X), Snn, Pnn, typS, typI'Address)
 757
 758    --  where rt is the root type of the expression, and typS and typI are
 759    --  the entities constructed as described in the spec for the procedure
 760    --  Build_Enumeration_Image_Tables and NN is 32/16/8 depending on the
 761    --  element type of Lit_Indexes. The rewriting of the expression to
 762    --  Snn (1 .. Pnn) then occurs as in the other cases. A special case is
 763    --  when pragma Discard_Names applies, in which case we replace expr by:
 764
 765    --     (rt'Pos (expr))'Image
 766
 767    --  So that the result is a space followed by the decimal value for the
 768    --  position of the enumeration value in the enumeration type.
 769
 770    procedure Expand_Image_Attribute (N : Node_Id) is
 771       Loc   : constant Source_Ptr := Sloc (N);
 772       Exprs : constant List_Id    := Expressions (N);
 773       Expr  : constant Node_Id    := Relocate_Node (First (Exprs));
 774       Pref  : constant Node_Id    := Prefix (N);
 775
 776       procedure Expand_Standard_Boolean_Image;
 777       --  Expand attribute 'Image in Standard.Boolean, avoiding string copy
 778
 779       procedure Expand_User_Defined_Enumeration_Image (Typ : Entity_Id);
 780       --  Expand attribute 'Image in user-defined enumeration types, avoiding
 781       --  string copy.
 782
 783       -----------------------------------
 784       -- Expand_Standard_Boolean_Image --
 785       -----------------------------------
 786
 787       procedure Expand_Standard_Boolean_Image is
 788          Ins_List : constant List_Id   := New_List;
 789          S1_Id    : constant Entity_Id := Make_Temporary (Loc, 'S');
 790          T_Id     : constant Entity_Id := Make_Temporary (Loc, 'T');
 791          F_Id     : constant Entity_Id := Make_Temporary (Loc, 'F');
 792          V_Id     : constant Entity_Id := Make_Temporary (Loc, 'V');
 793
 794       begin
 795          --  We use a single 5-character string subtype throughout so that the
 796          --  subtype of the string if-expression is constrained and, therefore,
 797          --  does not force the creation of a temporary during analysis.
 798
 799          --  Generate:
 800          --    subtype S1 is String (1 .. 5);
 801
 802          Append_To (Ins_List,
 803            Make_Subtype_Declaration (Loc,
 804              Defining_Identifier => S1_Id,
 805              Subtype_Indication  =>
 806                Make_Subtype_Indication (Loc,
 807                  Subtype_Mark =>
 808                    New_Occurrence_Of (Standard_String, Loc),
 809                  Constraint   =>
 810                    Make_Index_Or_Discriminant_Constraint (Loc,
 811                      Constraints => New_List (
 812                        Make_Range (Loc,
 813                          Low_Bound  => Make_Integer_Literal (Loc, 1),
 814                          High_Bound => Make_Integer_Literal (Loc, 5)))))));
 815
 816          --  Generate:
 817          --    T : constant String (1 .. 5) := "TRUE ";
 818
 819          Start_String;
 820          Store_String_Chars ("TRUE ");
 821
 822          Append_To (Ins_List,
 823            Make_Object_Declaration (Loc,
 824              Defining_Identifier => T_Id,
 825              Object_Definition   =>
 826                New_Occurrence_Of (S1_Id, Loc),
 827              Constant_Present    => True,
 828              Expression          => Make_String_Literal (Loc, End_String)));
 829
 830          --  Generate:
 831          --    F : constant String (1 .. 5) := "FALSE";
 832
 833          Start_String;
 834          Store_String_Chars ("FALSE");
 835
 836          Append_To (Ins_List,
 837            Make_Object_Declaration (Loc,
 838              Defining_Identifier => F_Id,
 839              Object_Definition   =>
 840                New_Occurrence_Of (S1_Id, Loc),
 841              Constant_Present    => True,
 842              Expression          => Make_String_Literal (Loc, End_String)));
 843
 844          --  Generate:
 845          --    V : String (1 .. 5) renames (if Expr then T else F);
 846
 847          Append_To (Ins_List,
 848            Make_Object_Renaming_Declaration (Loc,
 849              Defining_Identifier => V_Id,
 850              Subtype_Mark        =>
 851                New_Occurrence_Of (S1_Id, Loc),
 852              Name                =>
 853                Make_If_Expression (Loc,
 854                  Expressions => New_List (
 855                    Duplicate_Subexpr (Expr),
 856                    New_Occurrence_Of (T_Id, Loc),
 857                    New_Occurrence_Of (F_Id, Loc)))));
 858
 859          --  Insert all the above declarations before N. We suppress checks
 860          --  because everything is in range at this stage.
 861
 862          Insert_Actions (N, Ins_List, Suppress => All_Checks);
 863
 864          --  Final step is to rewrite the expression as a slice:
 865          --  V (1 .. (if Expr then 4 else 5)) and analyze, again with no
 866          --  checks, since we are sure that everything is OK.
 867
 868          Rewrite (N,
 869            Make_Slice (Loc,
 870               Prefix         => New_Occurrence_Of (V_Id, Loc),
 871               Discrete_Range =>
 872                 Make_Range (Loc,
 873                   Low_Bound  => Make_Integer_Literal (Loc, 1),
 874                   High_Bound =>
 875                     Make_If_Expression (Loc,
 876                       Expressions => New_List (
 877                         Duplicate_Subexpr (Expr),
 878                         Make_Integer_Literal (Loc, 4),
 879                         Make_Integer_Literal (Loc, 5))))));
 880
 881          Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
 882       end Expand_Standard_Boolean_Image;
 883
 884       -------------------------------------------
 885       -- Expand_User_Defined_Enumeration_Image --
 886       -------------------------------------------
 887
 888       procedure Expand_User_Defined_Enumeration_Image (Typ : Entity_Id) is
 889          Ins_List : constant List_Id   := New_List;
 890          P1_Id    : constant Entity_Id := Make_Temporary (Loc, 'P');
 891          P2_Id    : constant Entity_Id := Make_Temporary (Loc, 'P');
 892          P3_Id    : constant Entity_Id := Make_Temporary (Loc, 'P');
 893          P4_Id    : constant Entity_Id := Make_Temporary (Loc, 'P');
 894          S1_Id    : constant Entity_Id := Make_Temporary (Loc, 'S');
 895
 896       begin
 897          --  Apply a validity check, since it is a bit drastic to get a
 898          --  completely junk image value for an invalid value.
 899
 900          if not Expr_Known_Valid (Expr) then
 901             Insert_Valid_Check (Expr);
 902          end if;
 903
 904          --  Generate:
 905          --    P1 : constant Natural := Typ'Pos (Typ?(Expr));
 906
 907          Append_To (Ins_List,
 908            Make_Object_Declaration (Loc,
 909              Defining_Identifier => P1_Id,
 910              Object_Definition   =>
 911                New_Occurrence_Of (Standard_Natural, Loc),
 912              Constant_Present    => True,
 913              Expression          =>
 914                Convert_To (Standard_Natural,
 915                  Make_Attribute_Reference (Loc,
 916                    Attribute_Name => Name_Pos,
 917                    Prefix         => New_Occurrence_Of (Typ, Loc),
 918                    Expressions    => New_List (OK_Convert_To (Typ, Expr))))));
 919
 920          --  Compute the index of the string start, generating:
 921          --    P2 : constant Natural := call_put_enumN (P1);
 922
 923          Append_To (Ins_List,
 924            Make_Object_Declaration (Loc,
 925              Defining_Identifier => P2_Id,
 926              Object_Definition   =>
 927                New_Occurrence_Of (Standard_Natural, Loc),
 928              Constant_Present    => True,
 929              Expression          =>
 930                Convert_To (Standard_Natural,
 931                  Make_Indexed_Component (Loc,
 932                    Prefix      =>
 933                      New_Occurrence_Of (Lit_Indexes (Typ), Loc),
 934                    Expressions =>
 935                      New_List (New_Occurrence_Of (P1_Id, Loc))))));
 936
 937          --  Compute the index of the next value, generating:
 938          --    P3 : constant Natural := call_put_enumN (P1 + 1);
 939
 940          declare
 941             Add_Node : constant Node_Id :=
 942               Make_Op_Add (Loc,
 943                 Left_Opnd  => New_Occurrence_Of (P1_Id, Loc),
 944                 Right_Opnd => Make_Integer_Literal (Loc, Uint_1));
 945
 946          begin
 947             Append_To (Ins_List,
 948               Make_Object_Declaration (Loc,
 949                 Defining_Identifier => P3_Id,
 950                 Object_Definition   =>
 951                   New_Occurrence_Of (Standard_Natural, Loc),
 952                 Constant_Present    => True,
 953                 Expression          =>
 954                   Convert_To (Standard_Natural,
 955                     Make_Indexed_Component (Loc,
 956                       Prefix      =>
 957                         New_Occurrence_Of (Lit_Indexes (Typ), Loc),
 958                       Expressions =>
 959                         New_List (Add_Node)))));
 960          end;
 961
 962          --  Generate:
 963          --    P4 : String renames call_put_enumS (P2 .. P3 - 1);
 964
 965          declare
 966             Sub_Node : constant Node_Id :=
 967               Make_Op_Subtract (Loc,
 968                 Left_Opnd  => New_Occurrence_Of (P3_Id, Loc),
 969                 Right_Opnd => Make_Integer_Literal (Loc, Uint_1));
 970
 971          begin
 972             Append_To (Ins_List,
 973               Make_Object_Renaming_Declaration (Loc,
 974                 Defining_Identifier => P4_Id,
 975                 Subtype_Mark        =>
 976                   New_Occurrence_Of (Standard_String, Loc),
 977                 Name                =>
 978                   Make_Slice (Loc,
 979                     Prefix         =>
 980                       New_Occurrence_Of (Lit_Strings (Typ), Loc),
 981                     Discrete_Range =>
 982                       Make_Range (Loc,
 983                         Low_Bound  => New_Occurrence_Of (P2_Id, Loc),
 984                         High_Bound => Sub_Node))));
 985          end;
 986
 987          --  Generate:
 988          --    subtype S1 is String (1 .. P3 - P2);
 989
 990          declare
 991             HB : constant Node_Id :=
 992               Make_Op_Subtract (Loc,
 993                 Left_Opnd  => New_Occurrence_Of (P3_Id, Loc),
 994                 Right_Opnd => New_Occurrence_Of (P2_Id, Loc));
 995
 996          begin
 997             Append_To (Ins_List,
 998               Make_Subtype_Declaration (Loc,
 999                 Defining_Identifier => S1_Id,
1000                 Subtype_Indication  =>
1001                   Make_Subtype_Indication (Loc,
1002                     Subtype_Mark =>
1003                       New_Occurrence_Of (Standard_String, Loc),
1004                     Constraint   =>
1005                       Make_Index_Or_Discriminant_Constraint (Loc,
1006                         Constraints => New_List (
1007                           Make_Range (Loc,
1008                             Low_Bound  => Make_Integer_Literal (Loc, 1),
1009                             High_Bound => HB))))));
1010          end;
1011
1012          --  Insert all the above declarations before N. We suppress checks
1013          --  because everything is in range at this stage.
1014
1015          Insert_Actions (N, Ins_List, Suppress => All_Checks);
1016
1017          Rewrite (N,
1018            Unchecked_Convert_To (S1_Id, New_Occurrence_Of (P4_Id, Loc)));
1019
1020          Analyze_And_Resolve (N, Standard_String);
1021       end Expand_User_Defined_Enumeration_Image;
1022
1023       --  Local variables
1024
1025       Enum_Case : Boolean;
1026       Imid      : RE_Id;
1027       Proc_Ent  : Entity_Id;
1028       Ptyp      : Entity_Id;
1029       Rtyp      : Entity_Id;
1030       Tent      : Entity_Id := Empty;
1031       Ttyp      : Entity_Id;
1032
1033       Arg_List : List_Id;
1034       --  List of arguments for run-time procedure call
1035
1036       Ins_List : List_Id;
1037       --  List of actions to be inserted
1038
1039       Snn : constant Entity_Id := Make_Temporary (Loc, 'S');
1040       Pnn : constant Entity_Id := Make_Temporary (Loc, 'P');
1041
1042    --  Start of processing for Expand_Image_Attribute
1043
1044    begin
1045       if Is_Object_Image (Pref) then
1046          Rewrite_Object_Image (N, Pref, Name_Image, Standard_String);
1047          return;
1048       end if;
1049
1050       --  If Image should be transformed using Put_Image, then do so. See
1051       --  Exp_Put_Image for details.
1052
1053       if Exp_Put_Image.Image_Should_Call_Put_Image (N) then
1054          Rewrite (N, Exp_Put_Image.Build_Image_Call (N));
1055          Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
1056          return;
1057       end if;
1058
1059       Ptyp := Underlying_Type (Entity (Pref));
1060
1061       --  Ada 2022 allows 'Image on private types, so fetch the underlying
1062       --  type to obtain the structure of the type. We use the base type,
1063       --  not the root type for discrete types, to handle properly derived
1064       --  types, but we use the root type for enumeration types, because the
1065       --  literal map is attached to the root. Should be inherited ???
1066
1067       if Is_Real_Type (Ptyp) or else Is_Enumeration_Type (Ptyp) then
1068          Rtyp := Underlying_Type (Root_Type (Ptyp));
1069       else
1070          Rtyp := Underlying_Type (Base_Type (Ptyp));
1071       end if;
1072
1073       --  Set Imid (RE_Id of procedure to call), and Tent, target for the
1074       --  type conversion of the first argument for all possibilities.
1075
1076       Enum_Case := False;
1077
1078       if Rtyp = Standard_Boolean then
1079          --  Use inline expansion if the -gnatd_x switch is not passed to the
1080          --  compiler. Otherwise expand into a call to the runtime.
1081
1082          if not Debug_Flag_Underscore_X then
1083             Expand_Standard_Boolean_Image;
1084             return;
1085
1086          else
1087             Imid := RE_Image_Boolean;
1088             Tent := Rtyp;
1089          end if;
1090
1091       --  For standard character, we have to select the version which handles
1092       --  soft hyphen correctly, based on the version of Ada in use (this is
1093       --  ugly, but we have no choice).
1094
1095       elsif Rtyp = Standard_Character then
1096          if Ada_Version < Ada_2005 then
1097             Imid := RE_Image_Character;
1098          else
1099             Imid := RE_Image_Character_05;
1100          end if;
1101
1102          Tent := Rtyp;
1103
1104       elsif Rtyp = Standard_Wide_Character then
1105          Imid := RE_Image_Wide_Character;
1106          Tent := Rtyp;
1107
1108       elsif Rtyp = Standard_Wide_Wide_Character then
1109          Imid := RE_Image_Wide_Wide_Character;
1110          Tent := Rtyp;
1111
1112       elsif Is_Signed_Integer_Type (Rtyp) then
1113          if Esize (Rtyp) <= Standard_Integer_Size then
1114             Imid := RE_Image_Integer;
1115             Tent := Standard_Integer;
1116          elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
1117             Imid := RE_Image_Long_Long_Integer;
1118             Tent := Standard_Long_Long_Integer;
1119          else
1120             Imid := RE_Image_Long_Long_Long_Integer;
1121             Tent := Standard_Long_Long_Long_Integer;
1122          end if;
1123
1124       elsif Is_Modular_Integer_Type (Rtyp) then
1125          if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
1126             Imid := RE_Image_Unsigned;
1127             Tent := RTE (RE_Unsigned);
1128          elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then
1129             Imid := RE_Image_Long_Long_Unsigned;
1130             Tent := RTE (RE_Long_Long_Unsigned);
1131          else
1132             Imid := RE_Image_Long_Long_Long_Unsigned;
1133             Tent := RTE (RE_Long_Long_Long_Unsigned);
1134          end if;
1135
1136       elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
1137          if Esize (Rtyp) <= 32 then
1138             Imid := RE_Image_Decimal32;
1139             Tent := RTE (RE_Integer_32);
1140          elsif Esize (Rtyp) <= 64 then
1141             Imid := RE_Image_Decimal64;
1142             Tent := RTE (RE_Integer_64);
1143          else
1144             Imid := RE_Image_Decimal128;
1145             Tent := RTE (RE_Integer_128);
1146          end if;
1147
1148       elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
1149          declare
1150             Num : constant Uint := Norm_Num (Small_Value (Rtyp));
1151             Den : constant Uint := Norm_Den (Small_Value (Rtyp));
1152             Max : constant Uint := UI_Max (Num, Den);
1153             Min : constant Uint := UI_Min (Num, Den);
1154             Siz : constant Uint := Esize (Rtyp);
1155
1156          begin
1157             --  Note that we do not use sharp bounds to speed things up
1158
1159             if Siz <= 32
1160               and then Max <= Uint_2 ** 31
1161               and then (Min = Uint_1
1162                          or else (Num < Den and then Den <= Uint_2 ** 27)
1163                          or else (Den < Num and then Num <= Uint_2 ** 25))
1164             then
1165                Imid := RE_Image_Fixed32;
1166                Tent := RTE (RE_Integer_32);
1167             elsif Siz <= 64
1168               and then Max <= Uint_2 ** 63
1169               and then (Min = Uint_1
1170                          or else (Num < Den and then Den <= Uint_2 ** 59)
1171                          or else (Den < Num and then Num <= Uint_2 ** 53))
1172             then
1173                Imid := RE_Image_Fixed64;
1174                Tent := RTE (RE_Integer_64);
1175             elsif System_Max_Integer_Size = 128
1176               and then Max <= Uint_2 ** 127
1177               and then (Min = Uint_1
1178                          or else (Num < Den and then Den <= Uint_2 ** 123)
1179                          or else (Den < Num and then Num <= Uint_2 ** 122))
1180             then
1181                Imid := RE_Image_Fixed128;
1182                Tent := RTE (RE_Integer_128);
1183             else
1184                Imid := RE_Image_Fixed;
1185                Tent := Standard_Long_Float;
1186             end if;
1187          end;
1188
1189       elsif Is_Floating_Point_Type (Rtyp) then
1190          --  Short_Float and Float are the same type for GNAT
1191
1192          if Rtyp = Standard_Short_Float or else Rtyp = Standard_Float then
1193             Imid := RE_Image_Float;
1194             Tent := Standard_Float;
1195
1196          elsif Rtyp = Standard_Long_Float then
1197             Imid := RE_Image_Long_Float;
1198             Tent := Standard_Long_Float;
1199
1200          else
1201             Imid := RE_Image_Long_Long_Float;
1202             Tent := Standard_Long_Long_Float;
1203          end if;
1204
1205       --  Only other possibility is user-defined enumeration type
1206
1207       else
1208          pragma Assert (Is_Enumeration_Type (Rtyp));
1209
1210          if Discard_Names (First_Subtype (Ptyp))
1211            or else No (Lit_Strings (Rtyp))
1212          then
1213             --  When pragma Discard_Names applies to the first subtype, build
1214             --  (Long_Long_Integer (Pref'Pos (Expr)))'Image. The conversion is
1215             --  there to avoid applying 'Image directly in Universal_Integer,
1216             --  which can be a very large type. See also the handling of 'Val.
1217
1218             Rewrite (N,
1219               Make_Attribute_Reference (Loc,
1220                 Prefix =>
1221                   Convert_To (Standard_Long_Long_Integer,
1222                     Make_Attribute_Reference (Loc,
1223                     Prefix         => Pref,
1224                     Attribute_Name => Name_Pos,
1225                     Expressions    => New_List (Expr))),
1226                 Attribute_Name => Name_Image));
1227             Analyze_And_Resolve (N, Standard_String);
1228             return;
1229
1230          --  Use inline expansion if the -gnatd_x switch is not passed to the
1231          --  compiler. Otherwise expand into a call to the runtime.
1232
1233          elsif not Debug_Flag_Underscore_X then
1234             Expand_User_Defined_Enumeration_Image (Rtyp);
1235             return;
1236
1237          else
1238             Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1239
1240             if Ttyp = Standard_Integer_8 then
1241                Imid := RE_Image_Enumeration_8;
1242
1243             elsif Ttyp = Standard_Integer_16 then
1244                Imid := RE_Image_Enumeration_16;
1245
1246             else
1247                Imid := RE_Image_Enumeration_32;
1248             end if;
1249
1250             --  Apply a validity check, since it is a bit drastic to get a
1251             --  completely junk image value for an invalid value.
1252
1253             if not Expr_Known_Valid (Expr) then
1254                Insert_Valid_Check (Expr);
1255             end if;
1256
1257             Enum_Case := True;
1258          end if;
1259       end if;
1260
1261       --  Build first argument for call
1262
1263       if Enum_Case then
1264          Arg_List := New_List (
1265            Make_Attribute_Reference (Loc,
1266              Attribute_Name => Name_Pos,
1267              Prefix         => New_Occurrence_Of (Ptyp, Loc),
1268              Expressions    => New_List (Expr)));
1269
1270       --  AI12-0020: Ada 2022 allows 'Image for all types, including private
1271       --  types. If the full type is not a fixed-point type, then it is enough
1272       --  to set the Conversion_OK flag. However, that would not work for
1273       --  fixed-point types, because that flag changes the run-time semantics
1274       --  of fixed-point type conversions; therefore, we must first convert to
1275       --  Rtyp, and then to Tent.
1276
1277       else
1278          declare
1279             Conv : Node_Id;
1280
1281          begin
1282             if Is_Private_Type (Etype (Expr)) then
1283                if Is_Fixed_Point_Type (Rtyp) then
1284                   Conv := Convert_To (Tent, OK_Convert_To (Rtyp, Expr));
1285                else
1286                   Conv := OK_Convert_To (Tent, Expr);
1287                end if;
1288             else
1289                Conv := Convert_To (Tent, Expr);
1290             end if;
1291
1292             Arg_List := New_List (Conv);
1293          end;
1294       end if;
1295
1296       --  Build declarations of Snn and Pnn to be inserted
1297
1298       Ins_List := New_List (
1299
1300          --  Snn : String (1 .. typ'Width);
1301
1302          Make_Object_Declaration (Loc,
1303             Defining_Identifier => Snn,
1304             Object_Definition   =>
1305               Make_Subtype_Indication (Loc,
1306                 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
1307                 Constraint   =>
1308                   Make_Index_Or_Discriminant_Constraint (Loc,
1309                     Constraints => New_List (
1310                       Make_Range (Loc,
1311                         Low_Bound  => Make_Integer_Literal (Loc, 1),
1312                         High_Bound =>
1313                           Make_Attribute_Reference (Loc,
1314                             Prefix         => New_Occurrence_Of (Rtyp, Loc),
1315                             Attribute_Name => Name_Width)))))),
1316
1317          --  Pnn : Natural;
1318
1319          Make_Object_Declaration (Loc,
1320            Defining_Identifier => Pnn,
1321            Object_Definition   => New_Occurrence_Of (Standard_Natural, Loc)));
1322
1323       --  Append Snn, Pnn arguments
1324
1325       Append_To (Arg_List, New_Occurrence_Of (Snn, Loc));
1326       Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc));
1327
1328       --  Get entity of procedure to call
1329
1330       Proc_Ent := RTE (Imid);
1331
1332       --  If the procedure entity is empty, that means we have a case in
1333       --  no run time mode where the operation is not allowed, and an
1334       --  appropriate diagnostic has already been issued.
1335
1336       if No (Proc_Ent) then
1337          return;
1338       end if;
1339
1340       --  Otherwise complete preparation of arguments for run-time call
1341
1342       --  Add extra arguments for Enumeration case
1343
1344       if Enum_Case then
1345          Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
1346          Append_To (Arg_List,
1347            Make_Attribute_Reference (Loc,
1348              Prefix         => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1349              Attribute_Name => Name_Address));
1350
1351       --  For floating-point types, append Digits argument
1352
1353       elsif Is_Floating_Point_Type (Rtyp) then
1354          Append_To (Arg_List,
1355            Make_Attribute_Reference (Loc,
1356              Prefix         => New_Occurrence_Of (Ptyp, Loc),
1357              Attribute_Name => Name_Digits));
1358
1359       --  For decimal, append Scale and also set to do literal conversion
1360
1361       elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
1362          Set_Conversion_OK (First (Arg_List));
1363
1364          Append_To (Arg_List, Make_Integer_Literal (Loc, Scale_Value (Ptyp)));
1365
1366       --  For ordinary fixed-point types, append Num, Den, Fore, Aft parameters
1367       --  and also set to do literal conversion.
1368
1369       elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
1370          if Imid /= RE_Image_Fixed then
1371             Set_Conversion_OK (First (Arg_List));
1372
1373             Append_To (Arg_List,
1374               Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Ptyp))));
1375
1376             Append_To (Arg_List,
1377               Make_Integer_Literal (Loc, -Norm_Den (Small_Value (Ptyp))));
1378
1379             --  We want to compute the Fore value for the fixed point type
1380             --  whose mantissa type is Tent and whose small is typ'Small.
1381
1382             declare
1383                T : Ureal := Uint_2 ** (Esize (Tent) - 1) * Small_Value (Ptyp);
1384                F : Nat   := 2;
1385
1386             begin
1387                while T >= Ureal_10 loop
1388                   F := F + 1;
1389                   T := T / Ureal_10;
1390                end loop;
1391
1392                Append_To (Arg_List,
1393                   Make_Integer_Literal (Loc, UI_From_Int (F)));
1394             end;
1395          end if;
1396
1397          Append_To (Arg_List, Make_Integer_Literal (Loc, Aft_Value (Ptyp)));
1398
1399       --  For Wide_Character, append Ada 2005 indication
1400
1401       elsif Rtyp = Standard_Wide_Character then
1402          Append_To (Arg_List,
1403            New_Occurrence_Of
1404              (Boolean_Literals (Ada_Version >= Ada_2005), Loc));
1405       end if;
1406
1407       --  Now append the procedure call to the insert list
1408
1409       Append_To (Ins_List,
1410          Make_Procedure_Call_Statement (Loc,
1411           Name                   => New_Occurrence_Of (Proc_Ent, Loc),
1412           Parameter_Associations => Arg_List));
1413
1414       --  Insert declarations of Snn, Pnn, and the procedure call. We suppress
1415       --  checks because we are sure that everything is in range at this stage.
1416
1417       Insert_Actions (N, Ins_List, Suppress => All_Checks);
1418
1419       --  Final step is to rewrite the expression as a slice and analyze,
1420       --  again with no checks, since we are sure that everything is OK.
1421
1422       Rewrite (N,
1423         Make_Slice (Loc,
1424           Prefix         => New_Occurrence_Of (Snn, Loc),
1425           Discrete_Range =>
1426             Make_Range (Loc,
1427               Low_Bound  => Make_Integer_Literal (Loc, 1),
1428               High_Bound => New_Occurrence_Of (Pnn, Loc))));
1429
1430       Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
1431    end Expand_Image_Attribute;
1432
1433    ----------------------------------
1434    -- Expand_Valid_Value_Attribute --
1435    ----------------------------------
1436
1437    procedure Expand_Valid_Value_Attribute (N : Node_Id) is
1438       Loc   : constant Source_Ptr := Sloc (N);
1439       Btyp  : constant Entity_Id  := Base_Type (Entity (Prefix (N)));
1440       Rtyp  : constant Entity_Id  := Root_Type (Btyp);
1441       pragma Assert (Is_Enumeration_Type (Rtyp));
1442
1443       Args  : constant List_Id := Expressions (N);
1444       Func  : RE_Id;
1445       Ttyp  : Entity_Id;
1446
1447    begin
1448       --  Generate:
1449
1450       --     Valid_Value_Enumeration_NN
1451       --       (typS, typN'Address, typH'Unrestricted_Access, Num, X)
1452
1453       Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1454
1455       if Ttyp = Standard_Integer_8 then
1456          Func := RE_Valid_Value_Enumeration_8;
1457       elsif Ttyp = Standard_Integer_16 then
1458          Func := RE_Valid_Value_Enumeration_16;
1459       else
1460          Func := RE_Valid_Value_Enumeration_32;
1461       end if;
1462
1463       Prepend_To (Args,
1464         Make_Attribute_Reference (Loc,
1465           Prefix => New_Occurrence_Of (Rtyp, Loc),
1466           Attribute_Name => Name_Pos,
1467           Expressions => New_List (
1468             Make_Attribute_Reference (Loc,
1469               Prefix => New_Occurrence_Of (Rtyp, Loc),
1470               Attribute_Name => Name_Last))));
1471
1472       if Present (Lit_Hash (Rtyp)) then
1473          Prepend_To (Args,
1474            Make_Attribute_Reference (Loc,
1475              Prefix => New_Occurrence_Of (Lit_Hash (Rtyp), Loc),
1476              Attribute_Name => Name_Unrestricted_Access));
1477       else
1478          Prepend_To (Args, Make_Null (Loc));
1479       end if;
1480
1481       Prepend_To (Args,
1482         Make_Attribute_Reference (Loc,
1483           Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1484           Attribute_Name => Name_Address));
1485
1486       Prepend_To (Args,
1487         New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
1488
1489       Rewrite (N,
1490         Make_Function_Call (Loc,
1491           Name =>
1492             New_Occurrence_Of (RTE (Func), Loc),
1493           Parameter_Associations => Args));
1494
1495       Analyze_And_Resolve (N, Standard_Boolean);
1496    end Expand_Valid_Value_Attribute;
1497
1498    ----------------------------
1499    -- Expand_Value_Attribute --
1500    ----------------------------
1501
1502    --  For scalar types derived from Boolean, Character and integer types
1503    --  in package Standard, typ'Value (X) expands into:
1504
1505    --    btyp (Value_xx (X))
1506
1507    --  where btyp is the base type of the prefix
1508
1509    --    For types whose root type is Character
1510    --      xx = Character
1511
1512    --    For types whose root type is Wide_Character
1513    --      xx = Wide_Character
1514
1515    --    For types whose root type is Wide_Wide_Character
1516    --      xx = Wide_Wide_Character
1517
1518    --    For types whose root type is Boolean
1519    --      xx = Boolean
1520
1521    --    For signed integer types
1522    --      xx = [Long_Long_[Long_]]Integer
1523
1524    --    For modular types
1525    --      xx = [Long_Long_[Long_]]Unsigned
1526
1527    --    For floating-point types
1528    --      xx = [Long_[Long_]]Float
1529
1530    --  For decimal fixed-point types, typ'Value (X) expands into
1531
1532    --    btyp?(Value_Decimal{32,64,128} (X, typ'Scale));
1533
1534    --  For the most common ordinary fixed-point types, it expands into
1535
1536    --    btyp?(Value_Fixed{32,64,128} (X, numerator of S, denominator of S));
1537    --    where S = typ'Small
1538
1539    --  For other ordinary fixed-point types, it expands into
1540
1541    --    btyp (Value_Long_Float (X))
1542
1543    --  For Wide_[Wide_]Character types, typ'Value (X) expands into
1544
1545    --    btyp (Value_xx (X, EM))
1546
1547    --  where btyp is the base type of the prefix, and EM is the encoding method
1548
1549    --  For enumeration types other than those derived from types Boolean,
1550    --  Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
1551
1552    --    Enum'Val
1553    --      (Value_Enumeration_NN
1554    --        (typS, typN'Address, typH'Unrestricted_Access, Num, X))
1555
1556    --  where typS, typN and typH are the Lit_Strings, Lit_Indexes and Lit_Hash
1557    --  entities from T's root type entity, and Num is Enum'Pos (Enum'Last).
1558    --  The Value_Enumeration_NN function will search the tables looking for
1559    --  X and return the position number in the table if found which is
1560    --  used to provide the result of 'Value (using Enum'Val). If the
1561    --  value is not found Constraint_Error is raised. The suffix _NN
1562    --  depends on the element type of typN.
1563
1564    procedure Expand_Value_Attribute (N : Node_Id) is
1565       Loc   : constant Source_Ptr := Sloc (N);
1566       Btyp  : constant Entity_Id  := Etype (N);
1567       pragma Assert (Is_Base_Type (Btyp));
1568       pragma Assert (Btyp = Base_Type (Entity (Prefix (N))));
1569       Rtyp  : constant Entity_Id  := Root_Type (Btyp);
1570
1571       Args  : constant List_Id := Expressions (N);
1572       Ttyp  : Entity_Id;
1573       Vid   : RE_Id;
1574
1575    begin
1576       --  Fall through for all cases except user-defined enumeration type
1577       --  and decimal types, with Vid set to the Id of the entity for the
1578       --  Value routine and Args set to the list of parameters for the call.
1579
1580       if Rtyp = Standard_Boolean then
1581          Vid := RE_Value_Boolean;
1582
1583       elsif Rtyp = Standard_Character then
1584          Vid := RE_Value_Character;
1585
1586       elsif Rtyp = Standard_Wide_Character then
1587          Vid := RE_Value_Wide_Character;
1588
1589          Append_To (Args,
1590            Make_Integer_Literal (Loc,
1591              Intval => Int (Wide_Character_Encoding_Method)));
1592
1593       elsif Rtyp = Standard_Wide_Wide_Character then
1594          Vid := RE_Value_Wide_Wide_Character;
1595
1596          Append_To (Args,
1597            Make_Integer_Literal (Loc,
1598              Intval => Int (Wide_Character_Encoding_Method)));
1599
1600       elsif Is_Signed_Integer_Type (Rtyp) then
1601          if Esize (Rtyp) <= Standard_Integer_Size then
1602             Vid := RE_Value_Integer;
1603          elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
1604             Vid := RE_Value_Long_Long_Integer;
1605          else
1606             Vid := RE_Value_Long_Long_Long_Integer;
1607          end if;
1608
1609       elsif Is_Modular_Integer_Type (Rtyp) then
1610          if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
1611             Vid := RE_Value_Unsigned;
1612          elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then
1613             Vid := RE_Value_Long_Long_Unsigned;
1614          else
1615             Vid := RE_Value_Long_Long_Long_Unsigned;
1616          end if;
1617
1618       elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
1619          if Esize (Rtyp) <= 32 and then abs (Scale_Value (Rtyp)) <= 9 then
1620             Vid := RE_Value_Decimal32;
1621          elsif Esize (Rtyp) <= 64 and then abs (Scale_Value (Rtyp)) <= 18 then
1622             Vid := RE_Value_Decimal64;
1623          else
1624             Vid := RE_Value_Decimal128;
1625          end if;
1626
1627          Append_To (Args, Make_Integer_Literal (Loc, Scale_Value (Rtyp)));
1628
1629          Rewrite (N,
1630            OK_Convert_To (Btyp,
1631              Make_Function_Call (Loc,
1632                Name => New_Occurrence_Of (RTE (Vid), Loc),
1633                Parameter_Associations => Args)));
1634
1635          Set_Etype (N, Btyp);
1636          Analyze_And_Resolve (N, Btyp);
1637          return;
1638
1639       elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
1640          declare
1641             Num : constant Uint := Norm_Num (Small_Value (Rtyp));
1642             Den : constant Uint := Norm_Den (Small_Value (Rtyp));
1643             Max : constant Uint := UI_Max (Num, Den);
1644             Min : constant Uint := UI_Min (Num, Den);
1645             Siz : constant Uint := Esize (Rtyp);
1646
1647          begin
1648             if Siz <= 32
1649               and then Max <= Uint_2 ** 31
1650               and then (Min = Uint_1 or else Max <= Uint_2 ** 27)
1651             then
1652                Vid := RE_Value_Fixed32;
1653             elsif Siz <= 64
1654               and then Max <= Uint_2 ** 63
1655               and then (Min = Uint_1 or else Max <= Uint_2 ** 59)
1656             then
1657                Vid := RE_Value_Fixed64;
1658             elsif System_Max_Integer_Size = 128
1659               and then Max <= Uint_2 ** 127
1660               and then (Min = Uint_1 or else Max <= Uint_2 ** 123)
1661             then
1662                Vid := RE_Value_Fixed128;
1663             else
1664                Vid := RE_Value_Long_Float;
1665             end if;
1666
1667             if Vid /= RE_Value_Long_Float then
1668                Append_To (Args,
1669                  Make_Integer_Literal (Loc, -Norm_Num (Small_Value (Rtyp))));
1670
1671                Append_To (Args,
1672                  Make_Integer_Literal (Loc, -Norm_Den (Small_Value (Rtyp))));
1673
1674                Rewrite (N,
1675                  OK_Convert_To (Btyp,
1676                    Make_Function_Call (Loc,
1677                      Name => New_Occurrence_Of (RTE (Vid), Loc),
1678                      Parameter_Associations => Args)));
1679
1680                Set_Etype (N, Btyp);
1681                Analyze_And_Resolve (N, Btyp);
1682                return;
1683             end if;
1684          end;
1685
1686       elsif Is_Floating_Point_Type (Rtyp) then
1687          --  Short_Float and Float are the same type for GNAT
1688
1689          if Rtyp = Standard_Short_Float or else Rtyp = Standard_Float then
1690             Vid := RE_Value_Float;
1691
1692          elsif Rtyp = Standard_Long_Float then
1693             Vid := RE_Value_Long_Float;
1694
1695          else
1696             Vid := RE_Value_Long_Long_Float;
1697          end if;
1698
1699       --  Only other possibility is user-defined enumeration type
1700
1701       else
1702          pragma Assert (Is_Enumeration_Type (Rtyp));
1703
1704          --  Case of pragma Discard_Names, transform the Value
1705          --  attribute to Btyp'Val (Long_Long_Integer'Value (Args))
1706
1707          if Discard_Names (First_Subtype (Btyp))
1708            or else No (Lit_Strings (Rtyp))
1709          then
1710             Rewrite (N,
1711               Make_Attribute_Reference (Loc,
1712                 Prefix => New_Occurrence_Of (Btyp, Loc),
1713                 Attribute_Name => Name_Val,
1714                 Expressions => New_List (
1715                   Make_Attribute_Reference (Loc,
1716                     Prefix =>
1717                       New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
1718                     Attribute_Name => Name_Value,
1719                     Expressions => Args))));
1720
1721             Analyze_And_Resolve (N, Btyp);
1722
1723          --  Normal case where we have enumeration tables, build
1724
1725          --   T'Val
1726          --     (Value_Enumeration_NN
1727          --       (typS, typN'Address, typH'Unrestricted_Access, Num, X))
1728
1729          else
1730             Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1731
1732             if Ttyp = Standard_Integer_8 then
1733                Vid := RE_Value_Enumeration_8;
1734             elsif Ttyp = Standard_Integer_16 then
1735                Vid := RE_Value_Enumeration_16;
1736             else
1737                Vid := RE_Value_Enumeration_32;
1738             end if;
1739
1740             Prepend_To (Args,
1741               Make_Attribute_Reference (Loc,
1742                 Prefix => New_Occurrence_Of (Rtyp, Loc),
1743                 Attribute_Name => Name_Pos,
1744                 Expressions => New_List (
1745                   Make_Attribute_Reference (Loc,
1746                     Prefix => New_Occurrence_Of (Rtyp, Loc),
1747                     Attribute_Name => Name_Last))));
1748
1749             if Present (Lit_Hash (Rtyp)) then
1750                Prepend_To (Args,
1751                  Make_Attribute_Reference (Loc,
1752                    Prefix => New_Occurrence_Of (Lit_Hash (Rtyp), Loc),
1753                    Attribute_Name => Name_Unrestricted_Access));
1754             else
1755                Prepend_To (Args, Make_Null (Loc));
1756             end if;
1757
1758             Prepend_To (Args,
1759               Make_Attribute_Reference (Loc,
1760                 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1761                 Attribute_Name => Name_Address));
1762
1763             Prepend_To (Args,
1764               New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
1765
1766             Rewrite (N,
1767               Make_Attribute_Reference (Loc,
1768                 Prefix => New_Occurrence_Of (Btyp, Loc),
1769                 Attribute_Name => Name_Val,
1770                 Expressions => New_List (
1771                   Make_Function_Call (Loc,
1772                     Name =>
1773                       New_Occurrence_Of (RTE (Vid), Loc),
1774                     Parameter_Associations => Args))));
1775
1776             Analyze_And_Resolve (N, Btyp);
1777          end if;
1778
1779          return;
1780       end if;
1781
1782       --  Compiling package Ada.Tags under No_Run_Time_Mode we disable the
1783       --  expansion of the attribute into the function call statement to avoid
1784       --  generating spurious errors caused by the use of Integer_Address'Value
1785       --  in our implementation of Ada.Tags.Internal_Tag.
1786
1787       if No_Run_Time_Mode
1788         and then Is_RTE (Rtyp, RE_Integer_Address)
1789         and then RTU_Loaded (Ada_Tags)
1790         and then Cunit_Entity (Current_Sem_Unit)
1791                    = Body_Entity (RTU_Entity (Ada_Tags))
1792       then
1793          Rewrite (N,
1794            Unchecked_Convert_To (Rtyp,
1795              Make_Integer_Literal (Loc, Uint_0)));
1796
1797       else
1798          Rewrite (N,
1799            Convert_To (Btyp,
1800              Make_Function_Call (Loc,
1801                Name => New_Occurrence_Of (RTE (Vid), Loc),
1802                Parameter_Associations => Args)));
1803       end if;
1804
1805       Analyze_And_Resolve (N, Btyp);
1806    end Expand_Value_Attribute;
1807
1808    ---------------------------------
1809    -- Expand_Wide_Image_Attribute --
1810    ---------------------------------
1811
1812    --  We expand typ'Wide_Image (X) as follows. First we insert this code:
1813
1814    --    Rnn : Wide_String (1 .. rt'Wide_Width);
1815    --    Lnn : Natural;
1816    --    String_To_Wide_String
1817    --      (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
1818
1819    --  where rt is the root type of the prefix type
1820
1821    --  Now we replace the Wide_Image reference by
1822
1823    --    Rnn (1 .. Lnn)
1824
1825    --  This works in all cases because String_To_Wide_String converts any
1826    --  wide character escape sequences resulting from the Image call to the
1827    --  proper Wide_Character equivalent
1828
1829    --  not quite right for typ = Wide_Character ???
1830
1831    procedure Expand_Wide_Image_Attribute (N : Node_Id) is
1832       Loc  : constant Source_Ptr := Sloc (N);
1833       Pref : constant Node_Id    := Prefix (N);
1834       Rnn  : constant Entity_Id  := Make_Temporary (Loc, 'S');
1835       Lnn  : constant Entity_Id  := Make_Temporary (Loc, 'P');
1836       Rtyp : Entity_Id;
1837
1838    begin
1839       if Is_Object_Image (Pref) then
1840          Rewrite_Object_Image (N, Pref, Name_Wide_Image, Standard_Wide_String);
1841          return;
1842       end if;
1843
1844       --  If Image should be transformed using Put_Image, then do so. See
1845       --  Exp_Put_Image for details.
1846
1847       if Exp_Put_Image.Image_Should_Call_Put_Image (N) then
1848          Rewrite (N, Exp_Put_Image.Build_Image_Call (N));
1849          Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks);
1850          return;
1851       end if;
1852
1853       Rtyp := Root_Type (Entity (Pref));
1854
1855       Insert_Actions (N, New_List (
1856
1857          --  Rnn : Wide_String (1 .. base_typ'Width);
1858
1859          Make_Object_Declaration (Loc,
1860             Defining_Identifier => Rnn,
1861             Object_Definition   =>
1862               Make_Subtype_Indication (Loc,
1863                 Subtype_Mark =>
1864                   New_Occurrence_Of (Standard_Wide_String, Loc),
1865                 Constraint   =>
1866                   Make_Index_Or_Discriminant_Constraint (Loc,
1867                     Constraints => New_List (
1868                       Make_Range (Loc,
1869                         Low_Bound  => Make_Integer_Literal (Loc, 1),
1870                         High_Bound =>
1871                           Make_Attribute_Reference (Loc,
1872                             Prefix         => New_Occurrence_Of (Rtyp, Loc),
1873                             Attribute_Name => Name_Wide_Width)))))),
1874
1875          --  Lnn : Natural;
1876
1877          Make_Object_Declaration (Loc,
1878            Defining_Identifier => Lnn,
1879            Object_Definition   => New_Occurrence_Of (Standard_Natural, Loc)),
1880
1881          --    String_To_Wide_String
1882          --      (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
1883
1884          Make_Procedure_Call_Statement (Loc,
1885            Name =>
1886              New_Occurrence_Of (RTE (RE_String_To_Wide_String), Loc),
1887
1888            Parameter_Associations => New_List (
1889              Make_Attribute_Reference (Loc,
1890                Prefix         => Prefix (N),
1891                Attribute_Name => Name_Image,
1892                Expressions    => Expressions (N)),
1893              New_Occurrence_Of (Rnn, Loc),
1894              New_Occurrence_Of (Lnn, Loc),
1895              Make_Integer_Literal (Loc,
1896                Intval => Int (Wide_Character_Encoding_Method))))),
1897
1898          --  Suppress checks because we know everything is properly in range
1899
1900          Suppress => All_Checks);
1901
1902       --  Final step is to rewrite the expression as a slice and analyze,
1903       --  again with no checks, since we are sure that everything is OK.
1904
1905       Rewrite (N,
1906         Make_Slice (Loc,
1907           Prefix         => New_Occurrence_Of (Rnn, Loc),
1908           Discrete_Range =>
1909             Make_Range (Loc,
1910               Low_Bound  => Make_Integer_Literal (Loc, 1),
1911               High_Bound => New_Occurrence_Of (Lnn, Loc))));
1912
1913       Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks);
1914    end Expand_Wide_Image_Attribute;
1915
1916    --------------------------------------
1917    -- Expand_Wide_Wide_Image_Attribute --
1918    --------------------------------------
1919
1920    --  We expand typ'Wide_Wide_Image (X) as follows. First we insert this code:
1921
1922    --    Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
1923    --    Lnn : Natural;
1924    --    String_To_Wide_Wide_String
1925    --      (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
1926
1927    --  where rt is the root type of the prefix type
1928
1929    --  Now we replace the Wide_Wide_Image reference by
1930
1931    --    Rnn (1 .. Lnn)
1932
1933    --  This works in all cases because String_To_Wide_Wide_String converts any
1934    --  wide character escape sequences resulting from the Image call to the
1935    --  proper Wide_Wide_Character equivalent
1936
1937    --  not quite right for typ = Wide_Wide_Character ???
1938
1939    procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is
1940       Loc  : constant Source_Ptr := Sloc (N);
1941       Pref : constant Node_Id    := Prefix (N);
1942       Rnn  : constant Entity_Id  := Make_Temporary (Loc, 'S');
1943       Lnn  : constant Entity_Id  := Make_Temporary (Loc, 'P');
1944       Rtyp : Entity_Id;
1945
1946    begin
1947       if Is_Object_Image (Pref) then
1948          Rewrite_Object_Image
1949            (N, Pref, Name_Wide_Wide_Image, Standard_Wide_Wide_String);
1950          return;
1951       end if;
1952
1953       --  If Image should be transformed using Put_Image, then do so. See
1954       --  Exp_Put_Image for details.
1955
1956       if Exp_Put_Image.Image_Should_Call_Put_Image (N) then
1957          Rewrite (N, Exp_Put_Image.Build_Image_Call (N));
1958          Analyze_And_Resolve
1959            (N, Standard_Wide_Wide_String, Suppress => All_Checks);
1960          return;
1961       end if;
1962
1963       Rtyp := Root_Type (Entity (Pref));
1964
1965       Insert_Actions (N, New_List (
1966
1967          --  Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
1968
1969          Make_Object_Declaration (Loc,
1970             Defining_Identifier => Rnn,
1971             Object_Definition   =>
1972               Make_Subtype_Indication (Loc,
1973                 Subtype_Mark =>
1974                   New_Occurrence_Of (Standard_Wide_Wide_String, Loc),
1975                 Constraint   =>
1976                   Make_Index_Or_Discriminant_Constraint (Loc,
1977                     Constraints => New_List (
1978                       Make_Range (Loc,
1979                         Low_Bound  => Make_Integer_Literal (Loc, 1),
1980                         High_Bound =>
1981                           Make_Attribute_Reference (Loc,
1982                             Prefix         => New_Occurrence_Of (Rtyp, Loc),
1983                             Attribute_Name => Name_Wide_Wide_Width)))))),
1984
1985          --  Lnn : Natural;
1986
1987          Make_Object_Declaration (Loc,
1988            Defining_Identifier => Lnn,
1989            Object_Definition   => New_Occurrence_Of (Standard_Natural, Loc)),
1990
1991          --    String_To_Wide_Wide_String
1992          --      (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
1993
1994          Make_Procedure_Call_Statement (Loc,
1995            Name =>
1996              New_Occurrence_Of (RTE (RE_String_To_Wide_Wide_String), Loc),
1997
1998            Parameter_Associations => New_List (
1999              Make_Attribute_Reference (Loc,
2000                Prefix         => Prefix (N),
2001                Attribute_Name => Name_Image,
2002                Expressions    => Expressions (N)),
2003              New_Occurrence_Of (Rnn, Loc),
2004              New_Occurrence_Of (Lnn, Loc),
2005              Make_Integer_Literal (Loc,
2006                Intval => Int (Wide_Character_Encoding_Method))))),
2007
2008          --  Suppress checks because we know everything is properly in range
2009
2010          Suppress => All_Checks);
2011
2012       --  Final step is to rewrite the expression as a slice and analyze,
2013       --  again with no checks, since we are sure that everything is OK.
2014
2015       Rewrite (N,
2016         Make_Slice (Loc,
2017           Prefix         => New_Occurrence_Of (Rnn, Loc),
2018           Discrete_Range =>
2019             Make_Range (Loc,
2020               Low_Bound  => Make_Integer_Literal (Loc, 1),
2021               High_Bound => New_Occurrence_Of (Lnn, Loc))));
2022
2023       Analyze_And_Resolve
2024         (N, Standard_Wide_Wide_String, Suppress => All_Checks);
2025    end Expand_Wide_Wide_Image_Attribute;
2026
2027    ----------------------------
2028    -- Expand_Width_Attribute --
2029    ----------------------------
2030
2031    --  The processing here also handles the case of Wide_[Wide_]Width. With the
2032    --  exceptions noted, the processing is identical
2033
2034    --  For scalar types derived from Boolean, character and integer types
2035    --  in package Standard. Note that the Width attribute is computed at
2036    --  compile time for all cases except those involving non-static sub-
2037    --  types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
2038
2039    --    Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
2040
2041    --  where
2042
2043    --    For types whose root type is Character
2044    --      xx = Width_Character
2045    --      yy = Character
2046
2047    --    For types whose root type is Wide_Character
2048    --      xx = Wide_Width_Character
2049    --      yy = Character
2050
2051    --    For types whose root type is Wide_Wide_Character
2052    --      xx = Wide_Wide_Width_Character
2053    --      yy = Character
2054
2055    --    For types whose root type is Boolean
2056    --      xx = Width_Boolean
2057    --      yy = Boolean
2058
2059    --    For signed integer types
2060    --      xx = Width_[Long_Long_[Long_]]Integer
2061    --      yy = [Long_Long_[Long_]]Integer
2062
2063    --    For modular integer types
2064    --      xx = Width_[Long_Long_[Long_]]Unsigned
2065    --      yy = [Long_Long_[Long_]]Unsigned
2066
2067    --  For types derived from Wide_Character, typ'Width expands into
2068
2069    --    Result_Type (Width_Wide_Character (
2070    --      Wide_Character (typ'First),
2071    --      Wide_Character (typ'Last),
2072
2073    --  and typ'Wide_Width expands into:
2074
2075    --    Result_Type (Wide_Width_Wide_Character (
2076    --      Wide_Character (typ'First),
2077    --      Wide_Character (typ'Last));
2078
2079    --  and typ'Wide_Wide_Width expands into
2080
2081    --    Result_Type (Wide_Wide_Width_Wide_Character (
2082    --      Wide_Character (typ'First),
2083    --      Wide_Character (typ'Last));
2084
2085    --  For types derived from Wide_Wide_Character, typ'Width expands into
2086
2087    --    Result_Type (Width_Wide_Wide_Character (
2088    --      Wide_Wide_Character (typ'First),
2089    --      Wide_Wide_Character (typ'Last),
2090
2091    --  and typ'Wide_Width expands into:
2092
2093    --    Result_Type (Wide_Width_Wide_Wide_Character (
2094    --      Wide_Wide_Character (typ'First),
2095    --      Wide_Wide_Character (typ'Last));
2096
2097    --  and typ'Wide_Wide_Width expands into
2098
2099    --    Result_Type (Wide_Wide_Width_Wide_Wide_Char (
2100    --      Wide_Wide_Character (typ'First),
2101    --      Wide_Wide_Character (typ'Last));
2102
2103    --  For fixed point types, typ'Width and typ'Wide_[Wide_]Width expand into
2104
2105    --    if Ptyp'First > Ptyp'Last then 0 else Ptyp'Fore + 1 + Ptyp'Aft end if
2106
2107    --  and for floating point types, they expand into
2108
2109    --    if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
2110
2111    --  where btyp is the base type. This looks recursive but it isn't
2112    --  because the base type is always static, and hence the expression
2113    --  in the else is reduced to an integer literal.
2114
2115    --  For user-defined enumeration types, typ'Width expands into
2116
2117    --    Result_Type (Width_Enumeration_NN
2118    --                  (typS,
2119    --                   typI'Address,
2120    --                   typ'Pos (typ'First),
2121    --                   typ'Pos (Typ'Last)));
2122
2123    --  and typ'Wide_Width expands into:
2124
2125    --    Result_Type (Wide_Width_Enumeration_NN
2126    --                  (typS,
2127    --                   typI,
2128    --                   typ'Pos (typ'First),
2129    --                   typ'Pos (Typ'Last))
2130    --                   Wide_Character_Encoding_Method);
2131
2132    --  and typ'Wide_Wide_Width expands into:
2133
2134    --    Result_Type (Wide_Wide_Width_Enumeration_NN
2135    --                  (typS,
2136    --                   typI,
2137    --                   typ'Pos (typ'First),
2138    --                   typ'Pos (Typ'Last))
2139    --                   Wide_Character_Encoding_Method);
2140
2141    --  where typS and typI are the enumeration image strings and indexes
2142    --  table, as described in Build_Enumeration_Image_Tables. NN is 8/16/32
2143    --  for depending on the element type for typI.
2144
2145    --  Finally if Discard_Names is in effect for an enumeration type, then
2146    --  a special if expression is built that yields the space needed for the
2147    --  decimal representation of the largest pos value in the subtype. See
2148    --  code below for details.
2149
2150    procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is
2151       Loc     : constant Source_Ptr := Sloc (N);
2152       Typ     : constant Entity_Id  := Etype (N);
2153       Pref    : constant Node_Id    := Prefix (N);
2154       Ptyp    : constant Entity_Id  := Etype (Pref);
2155       Rtyp    : constant Entity_Id  := Root_Type (Ptyp);
2156       Arglist : List_Id;
2157       Ttyp    : Entity_Id;
2158       XX      : RE_Id;
2159       YY      : Entity_Id;
2160
2161    begin
2162       --  Types derived from Standard.Boolean
2163
2164       if Rtyp = Standard_Boolean then
2165          XX := RE_Width_Boolean;
2166          YY := Rtyp;
2167
2168       --  Types derived from Standard.Character
2169
2170       elsif Rtyp = Standard_Character then
2171          case Attr is
2172             when Normal    => XX := RE_Width_Character;
2173             when Wide      => XX := RE_Wide_Width_Character;
2174             when Wide_Wide => XX := RE_Wide_Wide_Width_Character;
2175          end case;
2176
2177          YY := Rtyp;
2178
2179       --  Types derived from Standard.Wide_Character
2180
2181       elsif Rtyp = Standard_Wide_Character then
2182          case Attr is
2183             when Normal    => XX := RE_Width_Wide_Character;
2184             when Wide      => XX := RE_Wide_Width_Wide_Character;
2185             when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character;
2186          end case;
2187
2188          YY := Rtyp;
2189
2190       --  Types derived from Standard.Wide_Wide_Character
2191
2192       elsif Rtyp = Standard_Wide_Wide_Character then
2193          case Attr is
2194             when Normal    => XX := RE_Width_Wide_Wide_Character;
2195             when Wide      => XX := RE_Wide_Width_Wide_Wide_Character;
2196             when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char;
2197          end case;
2198
2199          YY := Rtyp;
2200
2201       --  Signed integer types
2202
2203       elsif Is_Signed_Integer_Type (Rtyp) then
2204          if Esize (Rtyp) <= Standard_Integer_Size then
2205             XX := RE_Width_Integer;
2206             YY := Standard_Integer;
2207          elsif Esize (Rtyp) <= Standard_Long_Long_Integer_Size then
2208             XX := RE_Width_Long_Long_Integer;
2209             YY := Standard_Long_Long_Integer;
2210          else
2211             XX := RE_Width_Long_Long_Long_Integer;
2212             YY := Standard_Long_Long_Long_Integer;
2213          end if;
2214
2215       --  Modular integer types
2216
2217       elsif Is_Modular_Integer_Type (Rtyp) then
2218          if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
2219             XX := RE_Width_Unsigned;
2220             YY := RTE (RE_Unsigned);
2221          elsif Modulus (Rtyp) <= Modulus (RTE (RE_Long_Long_Unsigned)) then
2222             XX := RE_Width_Long_Long_Unsigned;
2223             YY := RTE (RE_Long_Long_Unsigned);
2224          else
2225             XX := RE_Width_Long_Long_Long_Unsigned;
2226             YY := RTE (RE_Long_Long_Long_Unsigned);
2227          end if;
2228
2229       --  Fixed point types
2230
2231       elsif Is_Fixed_Point_Type (Rtyp) then
2232          Rewrite (N,
2233            Make_If_Expression (Loc,
2234              Expressions => New_List (
2235
2236                Make_Op_Gt (Loc,
2237                  Left_Opnd =>
2238                    Make_Attribute_Reference (Loc,
2239                      Prefix => New_Occurrence_Of (Ptyp, Loc),
2240                      Attribute_Name => Name_First),
2241
2242                  Right_Opnd =>
2243                    Make_Attribute_Reference (Loc,
2244                      Prefix => New_Occurrence_Of (Ptyp, Loc),
2245                      Attribute_Name => Name_Last)),
2246
2247                Make_Integer_Literal (Loc, 0),
2248
2249                Make_Op_Add (Loc,
2250                  Make_Attribute_Reference (Loc,
2251                    Prefix => New_Occurrence_Of (Ptyp, Loc),
2252                    Attribute_Name => Name_Fore),
2253
2254                  Make_Op_Add (Loc,
2255                    Make_Integer_Literal (Loc, 1),
2256                    Make_Integer_Literal (Loc, Aft_Value (Ptyp)))))));
2257
2258          Analyze_And_Resolve (N, Typ);
2259          return;
2260
2261       --  Floating point types
2262
2263       elsif Is_Floating_Point_Type (Rtyp) then
2264          Rewrite (N,
2265            Make_If_Expression (Loc,
2266              Expressions => New_List (
2267
2268                Make_Op_Gt (Loc,
2269                  Left_Opnd =>
2270                    Make_Attribute_Reference (Loc,
2271                      Prefix => New_Occurrence_Of (Ptyp, Loc),
2272                      Attribute_Name => Name_First),
2273
2274                  Right_Opnd =>
2275                    Make_Attribute_Reference (Loc,
2276                      Prefix => New_Occurrence_Of (Ptyp, Loc),
2277                      Attribute_Name => Name_Last)),
2278
2279                Make_Integer_Literal (Loc, 0),
2280
2281                Make_Attribute_Reference (Loc,
2282                  Prefix => New_Occurrence_Of (Base_Type (Ptyp), Loc),
2283                  Attribute_Name => Name_Width))));
2284
2285          Analyze_And_Resolve (N, Typ);
2286          return;
2287
2288       --  User-defined enumeration types
2289
2290       else
2291          pragma Assert (Is_Enumeration_Type (Rtyp));
2292
2293          --  Whenever pragma Discard_Names is in effect, the value we need
2294          --  is the value needed to accommodate the largest integer pos value
2295          --  in the range of the subtype + 1 for the space at the start. We
2296          --  build:
2297
2298          --     Tnn : constant Integer := Rtyp'Pos (Ptyp'Last)
2299
2300          --  and replace the expression by
2301
2302          --     (if Ptyp'Range_Length = 0 then 0
2303          --      else (if Tnn < 10 then 2
2304          --            else (if Tnn < 100 then 3
2305          --                  ...
2306          --                      else n)))...
2307
2308          --  where n is equal to Rtyp'Pos (Ptyp'Last) + 1
2309
2310          --  Note: The above processing is in accordance with the intent of
2311          --  the RM, which is that Width should be related to the impl-defined
2312          --  behavior of Image. It is not clear what this means if Image is
2313          --  not defined (as in the configurable run-time case for GNAT) and
2314          --  gives an error at compile time.
2315
2316          --  We choose in this case to just go ahead and implement Width the
2317          --  same way, returning what Image would have returned if it has been
2318          --  available in the configurable run-time library.
2319
2320          if Discard_Names (Rtyp) then
2321             declare
2322                Tnn   : constant Entity_Id := Make_Temporary (Loc, 'T');
2323                Cexpr : Node_Id;
2324                P     : Int;
2325                M     : Int;
2326                K     : Int;
2327
2328             begin
2329                Insert_Action (N,
2330                  Make_Object_Declaration (Loc,
2331                    Defining_Identifier => Tnn,
2332                    Constant_Present    => True,
2333                    Object_Definition   =>
2334                      New_Occurrence_Of (Standard_Integer, Loc),
2335                    Expression =>
2336                      Make_Attribute_Reference (Loc,
2337                        Prefix         => New_Occurrence_Of (Rtyp, Loc),
2338                        Attribute_Name => Name_Pos,
2339                        Expressions    => New_List (
2340                          Convert_To (Rtyp,
2341                            Make_Attribute_Reference (Loc,
2342                              Prefix         => New_Occurrence_Of (Ptyp, Loc),
2343                              Attribute_Name => Name_Last))))));
2344
2345                --  OK, now we need to build the if expression. First get the
2346                --  value of M, the largest possible value needed.
2347
2348                P := UI_To_Int
2349                       (Enumeration_Pos (Entity (Type_High_Bound (Rtyp))));
2350
2351                K := 1;
2352                M := 1;
2353                while M < P loop
2354                   M := M * 10;
2355                   K := K + 1;
2356                end loop;
2357
2358                --  Build inner else
2359
2360                Cexpr := Make_Integer_Literal (Loc, K);
2361
2362                --  Wrap in inner if's until counted down to 2
2363
2364                while K > 2 loop
2365                   M := M / 10;
2366                   K := K - 1;
2367
2368                   Cexpr :=
2369                     Make_If_Expression (Loc,
2370                       Expressions => New_List (
2371                         Make_Op_Lt (Loc,
2372                           Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
2373                           Right_Opnd => Make_Integer_Literal (Loc, M)),
2374                         Make_Integer_Literal (Loc, K),
2375                         Cexpr));
2376                end loop;
2377
2378                --  Add initial comparison for null range and we are done, so
2379                --  rewrite the attribute occurrence with this expression.
2380
2381                Rewrite (N,
2382                  Convert_To (Typ,
2383                    Make_If_Expression (Loc,
2384                      Expressions => New_List (
2385                        Make_Op_Eq (Loc,
2386                          Left_Opnd  =>
2387                            Make_Attribute_Reference (Loc,
2388                              Prefix         => New_Occurrence_Of (Ptyp, Loc),
2389                              Attribute_Name => Name_Range_Length),
2390                          Right_Opnd => Make_Integer_Literal (Loc, 0)),
2391                        Make_Integer_Literal (Loc, 0),
2392                        Cexpr))));
2393
2394                Analyze_And_Resolve (N, Typ);
2395                return;
2396             end;
2397          end if;
2398
2399          --  Normal case, not Discard_Names
2400
2401          Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
2402
2403          case Attr is
2404             when Normal =>
2405                if Ttyp = Standard_Integer_8 then
2406                   XX := RE_Width_Enumeration_8;
2407                elsif Ttyp = Standard_Integer_16 then
2408                   XX := RE_Width_Enumeration_16;
2409                else
2410                   XX := RE_Width_Enumeration_32;
2411                end if;
2412
2413             when Wide =>
2414                if Ttyp = Standard_Integer_8 then
2415                   XX := RE_Wide_Width_Enumeration_8;
2416                elsif Ttyp = Standard_Integer_16 then
2417                   XX := RE_Wide_Width_Enumeration_16;
2418                else
2419                   XX := RE_Wide_Width_Enumeration_32;
2420                end if;
2421
2422             when Wide_Wide =>
2423                if Ttyp = Standard_Integer_8 then
2424                   XX := RE_Wide_Wide_Width_Enumeration_8;
2425                elsif Ttyp = Standard_Integer_16 then
2426                   XX := RE_Wide_Wide_Width_Enumeration_16;
2427                else
2428                   XX := RE_Wide_Wide_Width_Enumeration_32;
2429                end if;
2430          end case;
2431
2432          Arglist :=
2433            New_List (
2434              New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
2435
2436              Make_Attribute_Reference (Loc,
2437                Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
2438                Attribute_Name => Name_Address),
2439
2440              Make_Attribute_Reference (Loc,
2441                Prefix => New_Occurrence_Of (Ptyp, Loc),
2442                Attribute_Name => Name_Pos,
2443
2444                Expressions => New_List (
2445                  Make_Attribute_Reference (Loc,
2446                    Prefix => New_Occurrence_Of (Ptyp, Loc),
2447                    Attribute_Name => Name_First))),
2448
2449              Make_Attribute_Reference (Loc,
2450                Prefix => New_Occurrence_Of (Ptyp, Loc),
2451                Attribute_Name => Name_Pos,
2452
2453                Expressions => New_List (
2454                  Make_Attribute_Reference (Loc,
2455                    Prefix => New_Occurrence_Of (Ptyp, Loc),
2456                    Attribute_Name => Name_Last))));
2457
2458          Rewrite (N,
2459            Convert_To (Typ,
2460              Make_Function_Call (Loc,
2461                Name => New_Occurrence_Of (RTE (XX), Loc),
2462                Parameter_Associations => Arglist)));
2463
2464          Analyze_And_Resolve (N, Typ);
2465          return;
2466       end if;
2467
2468       --  If we fall through XX and YY are set
2469
2470       Arglist := New_List (
2471         Convert_To (YY,
2472           Make_Attribute_Reference (Loc,
2473             Prefix => New_Occurrence_Of (Ptyp, Loc),
2474             Attribute_Name => Name_First)),
2475
2476         Convert_To (YY,
2477           Make_Attribute_Reference (Loc,
2478             Prefix => New_Occurrence_Of (Ptyp, Loc),
2479             Attribute_Name => Name_Last)));
2480
2481       Rewrite (N,
2482         Convert_To (Typ,
2483           Make_Function_Call (Loc,
2484             Name => New_Occurrence_Of (RTE (XX), Loc),
2485             Parameter_Associations => Arglist)));
2486
2487       Analyze_And_Resolve (N, Typ);
2488    end Expand_Width_Attribute;
2489
2490    --------------------------
2491    -- Rewrite_Object_Image --
2492    --------------------------
2493
2494    procedure Rewrite_Object_Image
2495      (N         : Node_Id;
2496       Pref      : Node_Id;
2497       Attr_Name : Name_Id;
2498       Str_Typ   : Entity_Id)
2499    is
2500       Ptyp : Entity_Id;
2501
2502    begin
2503       Ptyp := Etype (Pref);
2504
2505       --  If the prefix is a component that depends on a discriminant, then
2506       --  create an actual subtype for it.
2507
2508       if Nkind (Pref) = N_Selected_Component then
2509          declare
2510             Decl : constant Node_Id :=
2511                      Build_Actual_Subtype_Of_Component (Ptyp, Pref);
2512          begin
2513             if Present (Decl) then
2514                Insert_Action (N, Decl);
2515                Ptyp := Defining_Identifier (Decl);
2516             end if;
2517          end;
2518       end if;
2519
2520       Rewrite (N,
2521         Make_Attribute_Reference (Sloc (N),
2522           Prefix         => New_Occurrence_Of (Ptyp, Sloc (N)),
2523           Attribute_Name => Attr_Name,
2524           Expressions    => New_List (Unchecked_Convert_To (Ptyp, Pref))));
2525
2526       Analyze_And_Resolve (N, Str_Typ);
2527    end Rewrite_Object_Image;
2528 end Exp_Imgv;