GCC v8.2
[gcc.git] / 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-2018, Free Software Foundation, Inc.         --
10 --                                                                          --
11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
12 -- terms of the  GNU General Public License as published  by the Free Soft- --
13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17 -- for  more details.  You should have  received  a copy of the GNU General --
18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
20 --                                                                          --
21 -- GNAT was originally developed  by the GNAT team at  New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
23 --                                                                          --
24 ------------------------------------------------------------------------------
25
26 with Atree;    use Atree;
27 with Casing;   use Casing;
28 with Checks;   use Checks;
29 with Einfo;    use Einfo;
30 with Exp_Util; use Exp_Util;
31 with Lib;      use Lib;
32 with Namet;    use Namet;
33 with Nmake;    use Nmake;
34 with Nlists;   use Nlists;
35 with Opt;      use Opt;
36 with Rtsfind;  use Rtsfind;
37 with Sem_Aux;  use Sem_Aux;
38 with Sem_Res;  use Sem_Res;
39 with Sem_Util; use Sem_Util;
40 with Sinfo;    use Sinfo;
41 with Snames;   use Snames;
42 with Stand;    use Stand;
43 with Stringt;  use Stringt;
44 with Tbuild;   use Tbuild;
45 with Ttypes;   use Ttypes;
46 with Uintp;    use Uintp;
47 with Urealp;   use Urealp;
48
49 package body Exp_Imgv is
50
51    function Has_Decimal_Small (E : Entity_Id) return Boolean;
52    --  Applies to all entities. True for a Decimal_Fixed_Point_Type, or an
53    --  Ordinary_Fixed_Point_Type with a small that is a negative power of ten.
54    --  Shouldn't this be in einfo.adb or sem_aux.adb???
55
56    procedure Rewrite_Object_Image
57      (N         : Node_Id;
58       Pref      : Entity_Id;
59       Attr_Name : Name_Id;
60       Str_Typ   : Entity_Id);
61    --  AI12-00124: Rewrite attribute 'Image when it is applied to an object
62    --  reference as an attribute applied to a type. N denotes the node to be
63    --  rewritten, Pref denotes the prefix of the 'Image attribute, and Name
64    --  and Str_Typ specify which specific string type and 'Image attribute to
65    --  apply (e.g. Name_Wide_Image and Standard_Wide_String).
66
67    ------------------------------------
68    -- Build_Enumeration_Image_Tables --
69    ------------------------------------
70
71    procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is
72       Loc  : constant Source_Ptr := Sloc (E);
73       Str  : String_Id;
74       Ind  : List_Id;
75       Lit  : Entity_Id;
76       Nlit : Nat;
77       Len  : Nat;
78       Estr : Entity_Id;
79       Eind : Entity_Id;
80       Ityp : Node_Id;
81
82    begin
83       --  Nothing to do for other than a root enumeration type
84
85       if E /= Root_Type (E) then
86          return;
87
88       --  Nothing to do if pragma Discard_Names applies
89
90       elsif Discard_Names (E) then
91          return;
92       end if;
93
94       --  Otherwise tables need constructing
95
96       Start_String;
97       Ind := New_List;
98       Lit := First_Literal (E);
99       Len := 1;
100       Nlit := 0;
101
102       loop
103          Append_To (Ind,
104            Make_Integer_Literal (Loc, UI_From_Int (Len)));
105
106          exit when No (Lit);
107          Nlit := Nlit + 1;
108
109          Get_Unqualified_Decoded_Name_String (Chars (Lit));
110
111          if Name_Buffer (1) /= ''' then
112             Set_Casing (All_Upper_Case);
113          end if;
114
115          Store_String_Chars (Name_Buffer (1 .. Name_Len));
116          Len := Len + Int (Name_Len);
117          Next_Literal (Lit);
118       end loop;
119
120       if Len < Int (2 ** (8 - 1)) then
121          Ityp := Standard_Integer_8;
122       elsif Len < Int (2 ** (16 - 1)) then
123          Ityp := Standard_Integer_16;
124       else
125          Ityp := Standard_Integer_32;
126       end if;
127
128       Str := End_String;
129
130       Estr :=
131         Make_Defining_Identifier (Loc,
132           Chars => New_External_Name (Chars (E), 'S'));
133
134       Eind :=
135         Make_Defining_Identifier (Loc,
136           Chars => New_External_Name (Chars (E), 'N'));
137
138       Set_Lit_Strings (E, Estr);
139       Set_Lit_Indexes (E, Eind);
140
141       Insert_Actions (N,
142         New_List (
143           Make_Object_Declaration (Loc,
144             Defining_Identifier => Estr,
145             Constant_Present    => True,
146             Object_Definition   =>
147               New_Occurrence_Of (Standard_String, Loc),
148             Expression          =>
149               Make_String_Literal (Loc,
150                 Strval => Str)),
151
152           Make_Object_Declaration (Loc,
153             Defining_Identifier => Eind,
154             Constant_Present    => True,
155
156             Object_Definition =>
157               Make_Constrained_Array_Definition (Loc,
158                 Discrete_Subtype_Definitions => New_List (
159                   Make_Range (Loc,
160                     Low_Bound  => Make_Integer_Literal (Loc, 0),
161                     High_Bound => Make_Integer_Literal (Loc, Nlit))),
162                 Component_Definition =>
163                   Make_Component_Definition (Loc,
164                     Aliased_Present    => False,
165                     Subtype_Indication => New_Occurrence_Of (Ityp, Loc))),
166
167             Expression          =>
168               Make_Aggregate (Loc,
169                 Expressions => Ind))),
170         Suppress => All_Checks);
171    end Build_Enumeration_Image_Tables;
172
173    ----------------------------
174    -- Expand_Image_Attribute --
175    ----------------------------
176
177    --  For all cases other than user-defined enumeration types, the scheme
178    --  is as follows. First we insert the following code:
179
180    --    Snn : String (1 .. rt'Width);
181    --    Pnn : Natural;
182    --    Image_xx (tv, Snn, Pnn [,pm]);
183    --
184    --  and then Expr is replaced by Snn (1 .. Pnn)
185
186    --  In the above expansion:
187
188    --    rt is the root type of the expression
189    --    tv is the expression with the value, usually a type conversion
190    --    pm is an extra parameter present in some cases
191
192    --  The following table shows tv, xx, and (if used) pm for the various
193    --  possible types of the argument:
194
195    --    For types whose root type is Character
196    --      xx = Character
197    --      tv = Character (Expr)
198
199    --    For types whose root type is Boolean
200    --      xx = Boolean
201    --      tv = Boolean (Expr)
202
203    --    For signed integer types with size <= Integer'Size
204    --      xx = Integer
205    --      tv = Integer (Expr)
206
207    --    For other signed integer types
208    --      xx = Long_Long_Integer
209    --      tv = Long_Long_Integer (Expr)
210
211    --    For modular types with modulus <= System.Unsigned_Types.Unsigned
212    --      xx = Unsigned
213    --      tv = System.Unsigned_Types.Unsigned (Expr)
214
215    --    For other modular integer types
216    --      xx = Long_Long_Unsigned
217    --      tv = System.Unsigned_Types.Long_Long_Unsigned (Expr)
218
219    --    For types whose root type is Wide_Character
220    --      xx = Wide_Character
221    --      tv = Wide_Character (Expr)
222    --      pm = Boolean, true if Ada 2005 mode, False otherwise
223
224    --    For types whose root type is Wide_Wide_Character
225    --      xx = Wide_Wide_Character
226    --      tv = Wide_Wide_Character (Expr)
227
228    --    For floating-point types
229    --      xx = Floating_Point
230    --      tv = Long_Long_Float (Expr)
231    --      pm = typ'Digits (typ = subtype of expression)
232
233    --    For ordinary fixed-point types
234    --      xx = Ordinary_Fixed_Point
235    --      tv = Long_Long_Float (Expr)
236    --      pm = typ'Aft (typ = subtype of expression)
237
238    --    For decimal fixed-point types with size = Integer'Size
239    --      xx = Decimal
240    --      tv = Integer (Expr)
241    --      pm = typ'Scale (typ = subtype of expression)
242
243    --    For decimal fixed-point types with size > Integer'Size
244    --      xx = Long_Long_Decimal
245    --      tv = Long_Long_Integer?(Expr) [convert with no scaling]
246    --      pm = typ'Scale (typ = subtype of expression)
247
248    --  For enumeration types other than those declared packages Standard
249    --  or System, Snn, Pnn, are expanded as above, but the call looks like:
250
251    --    Image_Enumeration_NN (rt'Pos (X), Snn, Pnn, typS, typI'Address)
252
253    --  where rt is the root type of the expression, and typS and typI are
254    --  the entities constructed as described in the spec for the procedure
255    --  Build_Enumeration_Image_Tables and NN is 32/16/8 depending on the
256    --  element type of Lit_Indexes. The rewriting of the expression to
257    --  Snn (1 .. Pnn) then occurs as in the other cases. A special case is
258    --  when pragma Discard_Names applies, in which case we replace expr by:
259
260    --     (rt'Pos (expr))'Img
261
262    --  So that the result is a space followed by the decimal value for the
263    --  position of the enumeration value in the enumeration type.
264
265    procedure Expand_Image_Attribute (N : Node_Id) is
266       Loc   : constant Source_Ptr := Sloc (N);
267       Exprs : constant List_Id    := Expressions (N);
268       Expr  : constant Node_Id    := Relocate_Node (First (Exprs));
269       Pref  : constant Node_Id    := Prefix (N);
270
271       procedure Expand_User_Defined_Enumeration_Image;
272       --  Expand attribute 'Image in user-defined enumeration types, avoiding
273       --  string copy.
274
275       function Is_User_Defined_Enumeration_Type
276         (Typ : Entity_Id) return Boolean;
277       --  Return True if Typ is a user-defined enumeration type
278
279       -------------------------------------------
280       -- Expand_User_Defined_Enumeration_Image --
281       -------------------------------------------
282
283       procedure Expand_User_Defined_Enumeration_Image is
284          Ins_List : constant List_Id   := New_List;
285          P1_Id    : constant Entity_Id := Make_Temporary (Loc, 'P');
286          P2_Id    : constant Entity_Id := Make_Temporary (Loc, 'P');
287          P3_Id    : constant Entity_Id := Make_Temporary (Loc, 'P');
288          P4_Id    : constant Entity_Id := Make_Temporary (Loc, 'P');
289          Ptyp     : constant Entity_Id := Entity (Pref);
290          Rtyp     : constant Entity_Id := Root_Type (Ptyp);
291          S1_Id    : constant Entity_Id := Make_Temporary (Loc, 'S');
292
293       begin
294          --  Apply a validity check, since it is a bit drastic to get a
295          --  completely junk image value for an invalid value.
296
297          if not Expr_Known_Valid (Expr) then
298             Insert_Valid_Check (Expr);
299          end if;
300
301          --  Generate:
302          --    P1 : constant Natural := Pos;
303
304          Append_To (Ins_List,
305            Make_Object_Declaration (Loc,
306              Defining_Identifier => P1_Id,
307              Object_Definition   =>
308                New_Occurrence_Of (Standard_Natural, Loc),
309              Constant_Present    => True,
310              Expression          =>
311                Convert_To (Standard_Natural,
312                  Make_Attribute_Reference (Loc,
313                    Attribute_Name => Name_Pos,
314                    Prefix         => New_Occurrence_Of (Ptyp, Loc),
315                    Expressions    => New_List (Expr)))));
316
317          --  Compute the index of the string start, generating:
318          --    P2 : constant Natural := call_put_enumN (P1);
319
320          Append_To (Ins_List,
321            Make_Object_Declaration (Loc,
322              Defining_Identifier => P2_Id,
323              Object_Definition   =>
324                New_Occurrence_Of (Standard_Natural, Loc),
325              Constant_Present    => True,
326              Expression          =>
327                Convert_To (Standard_Natural,
328                  Make_Indexed_Component (Loc,
329                    Prefix      =>
330                      New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
331                    Expressions =>
332                      New_List (New_Occurrence_Of (P1_Id, Loc))))));
333
334          --  Compute the index of the next value, generating:
335          --    P3 : constant Natural := call_put_enumN (P1 + 1);
336
337          declare
338             Add_Node : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
339
340          begin
341             Set_Left_Opnd  (Add_Node, New_Occurrence_Of (P1_Id, Loc));
342             Set_Right_Opnd (Add_Node, Make_Integer_Literal (Loc, 1));
343
344             Append_To (Ins_List,
345               Make_Object_Declaration (Loc,
346                 Defining_Identifier => P3_Id,
347                 Object_Definition   =>
348                   New_Occurrence_Of (Standard_Natural, Loc),
349                 Constant_Present    => True,
350                 Expression          =>
351                   Convert_To (Standard_Natural,
352                     Make_Indexed_Component (Loc,
353                       Prefix      =>
354                         New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
355                       Expressions =>
356                         New_List (Add_Node)))));
357          end;
358
359          --  Generate:
360          --    S4 : String renames call_put_enumS (S2 .. S3 - 1);
361
362          declare
363             Sub_Node : constant Node_Id := New_Op_Node (N_Op_Subtract, Loc);
364
365          begin
366             Set_Left_Opnd  (Sub_Node, New_Occurrence_Of (P3_Id, Loc));
367             Set_Right_Opnd (Sub_Node, Make_Integer_Literal (Loc, 1));
368
369             Append_To (Ins_List,
370               Make_Object_Renaming_Declaration (Loc,
371                 Defining_Identifier => P4_Id,
372                 Subtype_Mark        =>
373                   New_Occurrence_Of (Standard_String, Loc),
374                 Name                =>
375                   Make_Slice (Loc,
376                     Prefix         =>
377                       New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
378                     Discrete_Range =>
379                       Make_Range (Loc,
380                         Low_Bound  => New_Occurrence_Of (P2_Id, Loc),
381                         High_Bound => Sub_Node))));
382          end;
383
384          --  Generate:
385          --    subtype S1 is string (1 .. P3 - P2);
386
387          declare
388             HB : constant Node_Id := New_Op_Node (N_Op_Subtract, Loc);
389
390          begin
391             Set_Left_Opnd  (HB, New_Occurrence_Of (P3_Id, Loc));
392             Set_Right_Opnd (HB, New_Occurrence_Of (P2_Id, Loc));
393
394             Append_To (Ins_List,
395               Make_Subtype_Declaration (Loc,
396                 Defining_Identifier => S1_Id,
397                 Subtype_Indication  =>
398                   Make_Subtype_Indication (Loc,
399                     Subtype_Mark =>
400                       New_Occurrence_Of (Standard_String, Loc),
401                     Constraint   =>
402                       Make_Index_Or_Discriminant_Constraint (Loc,
403                         Constraints => New_List (
404                           Make_Range (Loc,
405                             Low_Bound  => Make_Integer_Literal (Loc, 1),
406                             High_Bound => HB))))));
407          end;
408
409          --  Insert all the above declarations before N. We suppress checks
410          --  because everything is in range at this stage.
411
412          Insert_Actions (N, Ins_List, Suppress => All_Checks);
413
414          Rewrite (N,
415            Unchecked_Convert_To (S1_Id, New_Occurrence_Of (P4_Id, Loc)));
416
417          Analyze_And_Resolve (N, Standard_String);
418       end Expand_User_Defined_Enumeration_Image;
419
420       --------------------------------------
421       -- Is_User_Defined_Enumeration_Type --
422       --------------------------------------
423
424       function Is_User_Defined_Enumeration_Type
425         (Typ : Entity_Id) return Boolean is
426       begin
427          return Ekind (Typ) = E_Enumeration_Type
428            and then Typ /= Standard_Boolean
429            and then Typ /= Standard_Character
430            and then Typ /= Standard_Wide_Character
431            and then Typ /= Standard_Wide_Wide_Character;
432       end Is_User_Defined_Enumeration_Type;
433
434       --  Local variables
435
436       Imid      : RE_Id;
437       Ptyp      : Entity_Id;
438       Rtyp      : Entity_Id;
439       Tent      : Entity_Id := Empty;
440       Ttyp      : Entity_Id;
441       Proc_Ent  : Entity_Id;
442       Enum_Case : Boolean;
443
444       Arg_List : List_Id;
445       --  List of arguments for run-time procedure call
446
447       Ins_List : List_Id;
448       --  List of actions to be inserted
449
450       Snn : constant Entity_Id := Make_Temporary (Loc, 'S');
451       Pnn : constant Entity_Id := Make_Temporary (Loc, 'P');
452
453    begin
454       if Is_Object_Image (Pref) then
455          Rewrite_Object_Image (N, Pref, Name_Image, Standard_String);
456          return;
457
458       --  Enable speed-optimized expansion of user-defined enumeration types
459       --  if we are compiling with optimizations enabled and enumeration type
460       --  literals are generated. Otherwise the call will be expanded into a
461       --  call to the runtime library.
462
463       elsif Optimization_Level > 0
464         and then not Global_Discard_Names
465         and then Is_User_Defined_Enumeration_Type (Root_Type (Entity (Pref)))
466       then
467          Expand_User_Defined_Enumeration_Image;
468          return;
469       end if;
470
471       Ptyp := Entity (Pref);
472       Rtyp := Root_Type (Ptyp);
473
474       --  Build declarations of Snn and Pnn to be inserted
475
476       Ins_List := New_List (
477
478          --  Snn : String (1 .. typ'Width);
479
480          Make_Object_Declaration (Loc,
481             Defining_Identifier => Snn,
482             Object_Definition   =>
483               Make_Subtype_Indication (Loc,
484                 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
485                 Constraint   =>
486                   Make_Index_Or_Discriminant_Constraint (Loc,
487                     Constraints => New_List (
488                       Make_Range (Loc,
489                         Low_Bound  => Make_Integer_Literal (Loc, 1),
490                         High_Bound =>
491                           Make_Attribute_Reference (Loc,
492                             Prefix         => New_Occurrence_Of (Rtyp, Loc),
493                             Attribute_Name => Name_Width)))))),
494
495          --  Pnn : Natural;
496
497          Make_Object_Declaration (Loc,
498            Defining_Identifier => Pnn,
499            Object_Definition   => New_Occurrence_Of (Standard_Natural, Loc)));
500
501       --  Set Imid (RE_Id of procedure to call), and Tent, target for the
502       --  type conversion of the first argument for all possibilities.
503
504       Enum_Case := False;
505
506       if Rtyp = Standard_Boolean then
507          Imid := RE_Image_Boolean;
508          Tent := Rtyp;
509
510       --  For standard character, we have to select the version which handles
511       --  soft hyphen correctly, based on the version of Ada in use (this is
512       --  ugly, but we have no choice).
513
514       elsif Rtyp = Standard_Character then
515          if Ada_Version < Ada_2005 then
516             Imid := RE_Image_Character;
517          else
518             Imid := RE_Image_Character_05;
519          end if;
520
521          Tent := Rtyp;
522
523       elsif Rtyp = Standard_Wide_Character then
524          Imid := RE_Image_Wide_Character;
525          Tent := Rtyp;
526
527       elsif Rtyp = Standard_Wide_Wide_Character then
528          Imid := RE_Image_Wide_Wide_Character;
529          Tent := Rtyp;
530
531       elsif Is_Signed_Integer_Type (Rtyp) then
532          if Esize (Rtyp) <= Esize (Standard_Integer) then
533             Imid := RE_Image_Integer;
534             Tent := Standard_Integer;
535          else
536             Imid := RE_Image_Long_Long_Integer;
537             Tent := Standard_Long_Long_Integer;
538          end if;
539
540       elsif Is_Modular_Integer_Type (Rtyp) then
541          if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
542             Imid := RE_Image_Unsigned;
543             Tent := RTE (RE_Unsigned);
544          else
545             Imid := RE_Image_Long_Long_Unsigned;
546             Tent := RTE (RE_Long_Long_Unsigned);
547          end if;
548
549       elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then
550          if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
551             Imid := RE_Image_Decimal;
552             Tent := Standard_Integer;
553          else
554             Imid := RE_Image_Long_Long_Decimal;
555             Tent := Standard_Long_Long_Integer;
556          end if;
557
558       elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
559          Imid := RE_Image_Ordinary_Fixed_Point;
560          Tent := Standard_Long_Long_Float;
561
562       elsif Is_Floating_Point_Type (Rtyp) then
563          Imid := RE_Image_Floating_Point;
564          Tent := Standard_Long_Long_Float;
565
566       --  Only other possibility is user-defined enumeration type
567
568       else
569          if Discard_Names (First_Subtype (Ptyp))
570            or else No (Lit_Strings (Root_Type (Ptyp)))
571          then
572             --  When pragma Discard_Names applies to the first subtype, build
573             --  (Pref'Pos (Expr))'Img.
574
575             Rewrite (N,
576               Make_Attribute_Reference (Loc,
577                 Prefix =>
578                    Make_Attribute_Reference (Loc,
579                      Prefix         => Pref,
580                      Attribute_Name => Name_Pos,
581                      Expressions    => New_List (Expr)),
582                 Attribute_Name =>
583                   Name_Img));
584             Analyze_And_Resolve (N, Standard_String);
585             return;
586
587          else
588             --  Here for enumeration type case
589
590             Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
591
592             if Ttyp = Standard_Integer_8 then
593                Imid := RE_Image_Enumeration_8;
594
595             elsif Ttyp = Standard_Integer_16 then
596                Imid := RE_Image_Enumeration_16;
597
598             else
599                Imid := RE_Image_Enumeration_32;
600             end if;
601
602             --  Apply a validity check, since it is a bit drastic to get a
603             --  completely junk image value for an invalid value.
604
605             if not Expr_Known_Valid (Expr) then
606                Insert_Valid_Check (Expr);
607             end if;
608
609             Enum_Case := True;
610          end if;
611       end if;
612
613       --  Build first argument for call
614
615       if Enum_Case then
616          Arg_List := New_List (
617            Make_Attribute_Reference (Loc,
618              Attribute_Name => Name_Pos,
619              Prefix         => New_Occurrence_Of (Ptyp, Loc),
620              Expressions    => New_List (Expr)));
621
622       else
623          Arg_List := New_List (Convert_To (Tent, Expr));
624       end if;
625
626       --  Append Snn, Pnn arguments
627
628       Append_To (Arg_List, New_Occurrence_Of (Snn, Loc));
629       Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc));
630
631       --  Get entity of procedure to call
632
633       Proc_Ent := RTE (Imid);
634
635       --  If the procedure entity is empty, that means we have a case in
636       --  no run time mode where the operation is not allowed, and an
637       --  appropriate diagnostic has already been issued.
638
639       if No (Proc_Ent) then
640          return;
641       end if;
642
643       --  Otherwise complete preparation of arguments for run-time call
644
645       --  Add extra arguments for Enumeration case
646
647       if Enum_Case then
648          Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
649          Append_To (Arg_List,
650            Make_Attribute_Reference (Loc,
651              Prefix         => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
652              Attribute_Name => Name_Address));
653
654       --  For floating-point types, append Digits argument
655
656       elsif Is_Floating_Point_Type (Rtyp) then
657          Append_To (Arg_List,
658            Make_Attribute_Reference (Loc,
659              Prefix         => New_Occurrence_Of (Ptyp, Loc),
660              Attribute_Name => Name_Digits));
661
662       --  For ordinary fixed-point types, append Aft parameter
663
664       elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
665          Append_To (Arg_List,
666            Make_Attribute_Reference (Loc,
667              Prefix         => New_Occurrence_Of (Ptyp, Loc),
668              Attribute_Name => Name_Aft));
669
670          if Has_Decimal_Small (Rtyp) then
671             Set_Conversion_OK (First (Arg_List));
672             Set_Etype (First (Arg_List), Tent);
673          end if;
674
675       --  For decimal, append Scale and also set to do literal conversion
676
677       elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
678          Append_To (Arg_List,
679            Make_Attribute_Reference (Loc,
680              Prefix         => New_Occurrence_Of (Ptyp, Loc),
681              Attribute_Name => Name_Scale));
682
683          Set_Conversion_OK (First (Arg_List));
684          Set_Etype (First (Arg_List), Tent);
685
686       --  For Wide_Character, append Ada 2005 indication
687
688       elsif Rtyp = Standard_Wide_Character then
689          Append_To (Arg_List,
690            New_Occurrence_Of
691              (Boolean_Literals (Ada_Version >= Ada_2005), Loc));
692       end if;
693
694       --  Now append the procedure call to the insert list
695
696       Append_To (Ins_List,
697          Make_Procedure_Call_Statement (Loc,
698           Name                   => New_Occurrence_Of (Proc_Ent, Loc),
699           Parameter_Associations => Arg_List));
700
701       --  Insert declarations of Snn, Pnn, and the procedure call. We suppress
702       --  checks because we are sure that everything is in range at this stage.
703
704       Insert_Actions (N, Ins_List, Suppress => All_Checks);
705
706       --  Final step is to rewrite the expression as a slice and analyze,
707       --  again with no checks, since we are sure that everything is OK.
708
709       Rewrite (N,
710         Make_Slice (Loc,
711           Prefix         => New_Occurrence_Of (Snn, Loc),
712           Discrete_Range =>
713             Make_Range (Loc,
714               Low_Bound  => Make_Integer_Literal (Loc, 1),
715               High_Bound => New_Occurrence_Of (Pnn, Loc))));
716
717       Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
718    end Expand_Image_Attribute;
719
720    ----------------------------
721    -- Expand_Value_Attribute --
722    ----------------------------
723
724    --  For scalar types derived from Boolean, Character and integer types
725    --  in package Standard, typ'Value (X) expands into:
726
727    --    btyp (Value_xx (X))
728
729    --  where btyp is he base type of the prefix
730
731    --    For types whose root type is Character
732    --      xx = Character
733
734    --    For types whose root type is Wide_Character
735    --      xx = Wide_Character
736
737    --    For types whose root type is Wide_Wide_Character
738    --      xx = Wide_Wide_Character
739
740    --    For types whose root type is Boolean
741    --      xx = Boolean
742
743    --    For signed integer types with size <= Integer'Size
744    --      xx = Integer
745
746    --    For other signed integer types
747    --      xx = Long_Long_Integer
748
749    --    For modular types with modulus <= System.Unsigned_Types.Unsigned
750    --      xx = Unsigned
751
752    --    For other modular integer types
753    --      xx = Long_Long_Unsigned
754
755    --    For floating-point types and ordinary fixed-point types
756    --      xx = Real
757
758    --  For Wide_[Wide_]Character types, typ'Value (X) expands into:
759
760    --    btyp (Value_xx (X, EM))
761
762    --  where btyp is the base type of the prefix, and EM is the encoding method
763
764    --  For decimal types with size <= Integer'Size, typ'Value (X)
765    --  expands into
766
767    --    btyp?(Value_Decimal (X, typ'Scale));
768
769    --  For all other decimal types, typ'Value (X) expands into
770
771    --    btyp?(Value_Long_Long_Decimal (X, typ'Scale))
772
773    --  For enumeration types other than those derived from types Boolean,
774    --  Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
775
776    --    Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
777
778    --  where typS and typI and the Lit_Strings and Lit_Indexes entities
779    --  from T's root type entity, and Num is Enum'Pos (Enum'Last). The
780    --  Value_Enumeration_NN function will search the tables looking for
781    --  X and return the position number in the table if found which is
782    --  used to provide the result of 'Value (using Enum'Val). If the
783    --  value is not found Constraint_Error is raised. The suffix _NN
784    --  depends on the element type of typI.
785
786    procedure Expand_Value_Attribute (N : Node_Id) is
787       Loc   : constant Source_Ptr := Sloc (N);
788       Typ   : constant Entity_Id  := Etype (N);
789       Btyp  : constant Entity_Id  := Base_Type (Typ);
790       Rtyp  : constant Entity_Id  := Root_Type (Typ);
791       Exprs : constant List_Id    := Expressions (N);
792       Vid   : RE_Id;
793       Args  : List_Id;
794       Func  : RE_Id;
795       Ttyp  : Entity_Id;
796
797    begin
798       Args := Exprs;
799
800       if Rtyp = Standard_Character then
801          Vid := RE_Value_Character;
802
803       elsif Rtyp = Standard_Boolean then
804          Vid := RE_Value_Boolean;
805
806       elsif Rtyp = Standard_Wide_Character then
807          Vid := RE_Value_Wide_Character;
808
809          Append_To (Args,
810            Make_Integer_Literal (Loc,
811              Intval => Int (Wide_Character_Encoding_Method)));
812
813       elsif Rtyp = Standard_Wide_Wide_Character then
814          Vid := RE_Value_Wide_Wide_Character;
815
816          Append_To (Args,
817            Make_Integer_Literal (Loc,
818              Intval => Int (Wide_Character_Encoding_Method)));
819
820       elsif     Rtyp = Base_Type (Standard_Short_Short_Integer)
821         or else Rtyp = Base_Type (Standard_Short_Integer)
822         or else Rtyp = Base_Type (Standard_Integer)
823       then
824          Vid := RE_Value_Integer;
825
826       elsif Is_Signed_Integer_Type (Rtyp) then
827          Vid := RE_Value_Long_Long_Integer;
828
829       elsif Is_Modular_Integer_Type (Rtyp) then
830          if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
831             Vid := RE_Value_Unsigned;
832          else
833             Vid := RE_Value_Long_Long_Unsigned;
834          end if;
835
836       elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
837          if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
838             Vid := RE_Value_Decimal;
839          else
840             Vid := RE_Value_Long_Long_Decimal;
841          end if;
842
843          Append_To (Args,
844            Make_Attribute_Reference (Loc,
845              Prefix => New_Occurrence_Of (Typ, Loc),
846              Attribute_Name => Name_Scale));
847
848          Rewrite (N,
849            OK_Convert_To (Btyp,
850              Make_Function_Call (Loc,
851                Name => New_Occurrence_Of (RTE (Vid), Loc),
852                Parameter_Associations => Args)));
853
854          Set_Etype (N, Btyp);
855          Analyze_And_Resolve (N, Btyp);
856          return;
857
858       elsif Is_Real_Type (Rtyp) then
859          Vid := RE_Value_Real;
860
861       --  Only other possibility is user-defined enumeration type
862
863       else
864          pragma Assert (Is_Enumeration_Type (Rtyp));
865
866          --  Case of pragma Discard_Names, transform the Value
867          --  attribute to Btyp'Val (Long_Long_Integer'Value (Args))
868
869          if Discard_Names (First_Subtype (Typ))
870            or else No (Lit_Strings (Rtyp))
871          then
872             Rewrite (N,
873               Make_Attribute_Reference (Loc,
874                 Prefix => New_Occurrence_Of (Btyp, Loc),
875                 Attribute_Name => Name_Val,
876                 Expressions => New_List (
877                   Make_Attribute_Reference (Loc,
878                     Prefix =>
879                       New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
880                     Attribute_Name => Name_Value,
881                     Expressions => Args))));
882
883             Analyze_And_Resolve (N, Btyp);
884
885          --  Here for normal case where we have enumeration tables, this
886          --  is where we build
887
888          --    T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
889
890          else
891             Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
892
893             if Ttyp = Standard_Integer_8 then
894                Func := RE_Value_Enumeration_8;
895             elsif Ttyp = Standard_Integer_16 then
896                Func := RE_Value_Enumeration_16;
897             else
898                Func := RE_Value_Enumeration_32;
899             end if;
900
901             Prepend_To (Args,
902               Make_Attribute_Reference (Loc,
903                 Prefix => New_Occurrence_Of (Rtyp, Loc),
904                 Attribute_Name => Name_Pos,
905                 Expressions => New_List (
906                   Make_Attribute_Reference (Loc,
907                     Prefix => New_Occurrence_Of (Rtyp, Loc),
908                     Attribute_Name => Name_Last))));
909
910             Prepend_To (Args,
911               Make_Attribute_Reference (Loc,
912                 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
913                 Attribute_Name => Name_Address));
914
915             Prepend_To (Args,
916               New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
917
918             Rewrite (N,
919               Make_Attribute_Reference (Loc,
920                 Prefix => New_Occurrence_Of (Typ, Loc),
921                 Attribute_Name => Name_Val,
922                 Expressions => New_List (
923                   Make_Function_Call (Loc,
924                     Name =>
925                       New_Occurrence_Of (RTE (Func), Loc),
926                     Parameter_Associations => Args))));
927
928             Analyze_And_Resolve (N, Btyp);
929          end if;
930
931          return;
932       end if;
933
934       --  Fall through for all cases except user-defined enumeration type
935       --  and decimal types, with Vid set to the Id of the entity for the
936       --  Value routine and Args set to the list of parameters for the call.
937
938       --  Compiling package Ada.Tags under No_Run_Time_Mode we disable the
939       --  expansion of the attribute into the function call statement to avoid
940       --  generating spurious errors caused by the use of Integer_Address'Value
941       --  in our implementation of Ada.Tags.Internal_Tag
942
943       --  Seems like a bit of a odd approach, there should be a better way ???
944
945       --  There is a better way, test RTE_Available ???
946
947       if No_Run_Time_Mode
948         and then Rtyp = RTE (RE_Integer_Address)
949         and then RTU_Loaded (Ada_Tags)
950         and then Cunit_Entity (Current_Sem_Unit)
951                    = Body_Entity (RTU_Entity (Ada_Tags))
952       then
953          Rewrite (N,
954            Unchecked_Convert_To (Rtyp,
955              Make_Integer_Literal (Loc, Uint_0)));
956       else
957          Rewrite (N,
958            Convert_To (Btyp,
959              Make_Function_Call (Loc,
960                Name => New_Occurrence_Of (RTE (Vid), Loc),
961                Parameter_Associations => Args)));
962       end if;
963
964       Analyze_And_Resolve (N, Btyp);
965    end Expand_Value_Attribute;
966
967    ---------------------------------
968    -- Expand_Wide_Image_Attribute --
969    ---------------------------------
970
971    --  We expand typ'Wide_Image (X) as follows. First we insert this code:
972
973    --    Rnn : Wide_String (1 .. rt'Wide_Width);
974    --    Lnn : Natural;
975    --    String_To_Wide_String
976    --      (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
977
978    --  where rt is the root type of the prefix type
979
980    --  Now we replace the Wide_Image reference by
981
982    --    Rnn (1 .. Lnn)
983
984    --  This works in all cases because String_To_Wide_String converts any
985    --  wide character escape sequences resulting from the Image call to the
986    --  proper Wide_Character equivalent
987
988    --  not quite right for typ = Wide_Character ???
989
990    procedure Expand_Wide_Image_Attribute (N : Node_Id) is
991       Loc  : constant Source_Ptr := Sloc (N);
992       Pref : constant Entity_Id  := Prefix (N);
993       Rnn  : constant Entity_Id  := Make_Temporary (Loc, 'S');
994       Lnn  : constant Entity_Id  := Make_Temporary (Loc, 'P');
995       Rtyp : Entity_Id;
996
997    begin
998       if Is_Object_Image (Pref) then
999          Rewrite_Object_Image (N, Pref, Name_Wide_Image, Standard_Wide_String);
1000          return;
1001       end if;
1002
1003       Rtyp := Root_Type (Entity (Pref));
1004
1005       Insert_Actions (N, New_List (
1006
1007          --  Rnn : Wide_String (1 .. base_typ'Width);
1008
1009          Make_Object_Declaration (Loc,
1010             Defining_Identifier => Rnn,
1011             Object_Definition   =>
1012               Make_Subtype_Indication (Loc,
1013                 Subtype_Mark =>
1014                   New_Occurrence_Of (Standard_Wide_String, Loc),
1015                 Constraint   =>
1016                   Make_Index_Or_Discriminant_Constraint (Loc,
1017                     Constraints => New_List (
1018                       Make_Range (Loc,
1019                         Low_Bound  => Make_Integer_Literal (Loc, 1),
1020                         High_Bound =>
1021                           Make_Attribute_Reference (Loc,
1022                             Prefix         => New_Occurrence_Of (Rtyp, Loc),
1023                             Attribute_Name => Name_Wide_Width)))))),
1024
1025          --  Lnn : Natural;
1026
1027          Make_Object_Declaration (Loc,
1028            Defining_Identifier => Lnn,
1029            Object_Definition   => New_Occurrence_Of (Standard_Natural, Loc)),
1030
1031          --    String_To_Wide_String
1032          --      (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
1033
1034          Make_Procedure_Call_Statement (Loc,
1035            Name =>
1036              New_Occurrence_Of (RTE (RE_String_To_Wide_String), Loc),
1037
1038            Parameter_Associations => New_List (
1039              Make_Attribute_Reference (Loc,
1040                Prefix         => Prefix (N),
1041                Attribute_Name => Name_Image,
1042                Expressions    => Expressions (N)),
1043              New_Occurrence_Of (Rnn, Loc),
1044              New_Occurrence_Of (Lnn, Loc),
1045              Make_Integer_Literal (Loc,
1046                Intval => Int (Wide_Character_Encoding_Method))))),
1047
1048          --  Suppress checks because we know everything is properly in range
1049
1050          Suppress => All_Checks);
1051
1052       --  Final step is to rewrite the expression as a slice and analyze,
1053       --  again with no checks, since we are sure that everything is OK.
1054
1055       Rewrite (N,
1056         Make_Slice (Loc,
1057           Prefix         => New_Occurrence_Of (Rnn, Loc),
1058           Discrete_Range =>
1059             Make_Range (Loc,
1060               Low_Bound  => Make_Integer_Literal (Loc, 1),
1061               High_Bound => New_Occurrence_Of (Lnn, Loc))));
1062
1063       Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks);
1064    end Expand_Wide_Image_Attribute;
1065
1066    --------------------------------------
1067    -- Expand_Wide_Wide_Image_Attribute --
1068    --------------------------------------
1069
1070    --  We expand typ'Wide_Wide_Image (X) as follows. First we insert this code:
1071
1072    --    Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
1073    --    Lnn : Natural;
1074    --    String_To_Wide_Wide_String
1075    --      (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
1076
1077    --  where rt is the root type of the prefix type
1078
1079    --  Now we replace the Wide_Wide_Image reference by
1080
1081    --    Rnn (1 .. Lnn)
1082
1083    --  This works in all cases because String_To_Wide_Wide_String converts any
1084    --  wide character escape sequences resulting from the Image call to the
1085    --  proper Wide_Wide_Character equivalent
1086
1087    --  not quite right for typ = Wide_Wide_Character ???
1088
1089    procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is
1090       Loc  : constant Source_Ptr := Sloc (N);
1091       Pref : constant Entity_Id  := Prefix (N);
1092       Rnn  : constant Entity_Id  := Make_Temporary (Loc, 'S');
1093       Lnn  : constant Entity_Id  := Make_Temporary (Loc, 'P');
1094       Rtyp : Entity_Id;
1095
1096    begin
1097       if Is_Object_Image (Pref) then
1098          Rewrite_Object_Image
1099            (N, Pref, Name_Wide_Wide_Image, Standard_Wide_Wide_String);
1100          return;
1101       end if;
1102
1103       Rtyp := Root_Type (Entity (Pref));
1104
1105       Insert_Actions (N, New_List (
1106
1107          --  Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
1108
1109          Make_Object_Declaration (Loc,
1110             Defining_Identifier => Rnn,
1111             Object_Definition   =>
1112               Make_Subtype_Indication (Loc,
1113                 Subtype_Mark =>
1114                   New_Occurrence_Of (Standard_Wide_Wide_String, Loc),
1115                 Constraint   =>
1116                   Make_Index_Or_Discriminant_Constraint (Loc,
1117                     Constraints => New_List (
1118                       Make_Range (Loc,
1119                         Low_Bound  => Make_Integer_Literal (Loc, 1),
1120                         High_Bound =>
1121                           Make_Attribute_Reference (Loc,
1122                             Prefix         => New_Occurrence_Of (Rtyp, Loc),
1123                             Attribute_Name => Name_Wide_Wide_Width)))))),
1124
1125          --  Lnn : Natural;
1126
1127          Make_Object_Declaration (Loc,
1128            Defining_Identifier => Lnn,
1129            Object_Definition   => New_Occurrence_Of (Standard_Natural, Loc)),
1130
1131          --    String_To_Wide_Wide_String
1132          --      (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
1133
1134          Make_Procedure_Call_Statement (Loc,
1135            Name =>
1136              New_Occurrence_Of (RTE (RE_String_To_Wide_Wide_String), Loc),
1137
1138            Parameter_Associations => New_List (
1139              Make_Attribute_Reference (Loc,
1140                Prefix         => Prefix (N),
1141                Attribute_Name => Name_Image,
1142                Expressions    => Expressions (N)),
1143              New_Occurrence_Of (Rnn, Loc),
1144              New_Occurrence_Of (Lnn, Loc),
1145              Make_Integer_Literal (Loc,
1146                Intval => Int (Wide_Character_Encoding_Method))))),
1147
1148          --  Suppress checks because we know everything is properly in range
1149
1150          Suppress => All_Checks);
1151
1152       --  Final step is to rewrite the expression as a slice and analyze,
1153       --  again with no checks, since we are sure that everything is OK.
1154
1155       Rewrite (N,
1156         Make_Slice (Loc,
1157           Prefix         => New_Occurrence_Of (Rnn, Loc),
1158           Discrete_Range =>
1159             Make_Range (Loc,
1160               Low_Bound  => Make_Integer_Literal (Loc, 1),
1161               High_Bound => New_Occurrence_Of (Lnn, Loc))));
1162
1163       Analyze_And_Resolve
1164         (N, Standard_Wide_Wide_String, Suppress => All_Checks);
1165    end Expand_Wide_Wide_Image_Attribute;
1166
1167    ----------------------------
1168    -- Expand_Width_Attribute --
1169    ----------------------------
1170
1171    --  The processing here also handles the case of Wide_[Wide_]Width. With the
1172    --  exceptions noted, the processing is identical
1173
1174    --  For scalar types derived from Boolean, character and integer types
1175    --  in package Standard. Note that the Width attribute is computed at
1176    --  compile time for all cases except those involving non-static sub-
1177    --  types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
1178
1179    --    Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
1180
1181    --  where
1182
1183    --    For types whose root type is Character
1184    --      xx = Width_Character
1185    --      yy = Character
1186
1187    --    For types whose root type is Wide_Character
1188    --      xx = Wide_Width_Character
1189    --      yy = Character
1190
1191    --    For types whose root type is Wide_Wide_Character
1192    --      xx = Wide_Wide_Width_Character
1193    --      yy = Character
1194
1195    --    For types whose root type is Boolean
1196    --      xx = Width_Boolean
1197    --      yy = Boolean
1198
1199    --    For signed integer types
1200    --      xx = Width_Long_Long_Integer
1201    --      yy = Long_Long_Integer
1202
1203    --    For modular integer types
1204    --      xx = Width_Long_Long_Unsigned
1205    --      yy = Long_Long_Unsigned
1206
1207    --  For types derived from Wide_Character, typ'Width expands into
1208
1209    --    Result_Type (Width_Wide_Character (
1210    --      Wide_Character (typ'First),
1211    --      Wide_Character (typ'Last),
1212
1213    --  and typ'Wide_Width expands into:
1214
1215    --    Result_Type (Wide_Width_Wide_Character (
1216    --      Wide_Character (typ'First),
1217    --      Wide_Character (typ'Last));
1218
1219    --  and typ'Wide_Wide_Width expands into
1220
1221    --    Result_Type (Wide_Wide_Width_Wide_Character (
1222    --      Wide_Character (typ'First),
1223    --      Wide_Character (typ'Last));
1224
1225    --  For types derived from Wide_Wide_Character, typ'Width expands into
1226
1227    --    Result_Type (Width_Wide_Wide_Character (
1228    --      Wide_Wide_Character (typ'First),
1229    --      Wide_Wide_Character (typ'Last),
1230
1231    --  and typ'Wide_Width expands into:
1232
1233    --    Result_Type (Wide_Width_Wide_Wide_Character (
1234    --      Wide_Wide_Character (typ'First),
1235    --      Wide_Wide_Character (typ'Last));
1236
1237    --  and typ'Wide_Wide_Width expands into
1238
1239    --    Result_Type (Wide_Wide_Width_Wide_Wide_Char (
1240    --      Wide_Wide_Character (typ'First),
1241    --      Wide_Wide_Character (typ'Last));
1242
1243    --  For real types, typ'Width and typ'Wide_[Wide_]Width expand into
1244
1245    --    if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
1246
1247    --  where btyp is the base type. This looks recursive but it isn't
1248    --  because the base type is always static, and hence the expression
1249    --  in the else is reduced to an integer literal.
1250
1251    --  For user-defined enumeration types, typ'Width expands into
1252
1253    --    Result_Type (Width_Enumeration_NN
1254    --                  (typS,
1255    --                   typI'Address,
1256    --                   typ'Pos (typ'First),
1257    --                   typ'Pos (Typ'Last)));
1258
1259    --  and typ'Wide_Width expands into:
1260
1261    --    Result_Type (Wide_Width_Enumeration_NN
1262    --                  (typS,
1263    --                   typI,
1264    --                   typ'Pos (typ'First),
1265    --                   typ'Pos (Typ'Last))
1266    --                   Wide_Character_Encoding_Method);
1267
1268    --  and typ'Wide_Wide_Width expands into:
1269
1270    --    Result_Type (Wide_Wide_Width_Enumeration_NN
1271    --                  (typS,
1272    --                   typI,
1273    --                   typ'Pos (typ'First),
1274    --                   typ'Pos (Typ'Last))
1275    --                   Wide_Character_Encoding_Method);
1276
1277    --  where typS and typI are the enumeration image strings and indexes
1278    --  table, as described in Build_Enumeration_Image_Tables. NN is 8/16/32
1279    --  for depending on the element type for typI.
1280
1281    --  Finally if Discard_Names is in effect for an enumeration type, then
1282    --  a special if expression is built that yields the space needed for the
1283    --  decimal representation of the largest pos value in the subtype. See
1284    --  code below for details.
1285
1286    procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is
1287       Loc     : constant Source_Ptr := Sloc (N);
1288       Typ     : constant Entity_Id  := Etype (N);
1289       Pref    : constant Node_Id    := Prefix (N);
1290       Ptyp    : constant Entity_Id  := Etype (Pref);
1291       Rtyp    : constant Entity_Id  := Root_Type (Ptyp);
1292       Arglist : List_Id;
1293       Ttyp    : Entity_Id;
1294       XX      : RE_Id;
1295       YY      : Entity_Id;
1296
1297    begin
1298       --  Types derived from Standard.Boolean
1299
1300       if Rtyp = Standard_Boolean then
1301          XX := RE_Width_Boolean;
1302          YY := Rtyp;
1303
1304       --  Types derived from Standard.Character
1305
1306       elsif Rtyp = Standard_Character then
1307          case Attr is
1308             when Normal    => XX := RE_Width_Character;
1309             when Wide      => XX := RE_Wide_Width_Character;
1310             when Wide_Wide => XX := RE_Wide_Wide_Width_Character;
1311          end case;
1312
1313          YY := Rtyp;
1314
1315       --  Types derived from Standard.Wide_Character
1316
1317       elsif Rtyp = Standard_Wide_Character then
1318          case Attr is
1319             when Normal    => XX := RE_Width_Wide_Character;
1320             when Wide      => XX := RE_Wide_Width_Wide_Character;
1321             when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character;
1322          end case;
1323
1324          YY := Rtyp;
1325
1326       --  Types derived from Standard.Wide_Wide_Character
1327
1328       elsif Rtyp = Standard_Wide_Wide_Character then
1329          case Attr is
1330             when Normal    => XX := RE_Width_Wide_Wide_Character;
1331             when Wide      => XX := RE_Wide_Width_Wide_Wide_Character;
1332             when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char;
1333          end case;
1334
1335          YY := Rtyp;
1336
1337       --  Signed integer types
1338
1339       elsif Is_Signed_Integer_Type (Rtyp) then
1340          XX := RE_Width_Long_Long_Integer;
1341          YY := Standard_Long_Long_Integer;
1342
1343       --  Modular integer types
1344
1345       elsif Is_Modular_Integer_Type (Rtyp) then
1346          XX := RE_Width_Long_Long_Unsigned;
1347          YY := RTE (RE_Long_Long_Unsigned);
1348
1349       --  Real types
1350
1351       elsif Is_Real_Type (Rtyp) then
1352          Rewrite (N,
1353            Make_If_Expression (Loc,
1354              Expressions => New_List (
1355
1356                Make_Op_Gt (Loc,
1357                  Left_Opnd =>
1358                    Make_Attribute_Reference (Loc,
1359                      Prefix => New_Occurrence_Of (Ptyp, Loc),
1360                      Attribute_Name => Name_First),
1361
1362                  Right_Opnd =>
1363                    Make_Attribute_Reference (Loc,
1364                      Prefix => New_Occurrence_Of (Ptyp, Loc),
1365                      Attribute_Name => Name_Last)),
1366
1367                Make_Integer_Literal (Loc, 0),
1368
1369                Make_Attribute_Reference (Loc,
1370                  Prefix => New_Occurrence_Of (Base_Type (Ptyp), Loc),
1371                  Attribute_Name => Name_Width))));
1372
1373          Analyze_And_Resolve (N, Typ);
1374          return;
1375
1376       --  User-defined enumeration types
1377
1378       else
1379          pragma Assert (Is_Enumeration_Type (Rtyp));
1380
1381          --  Whenever pragma Discard_Names is in effect, the value we need
1382          --  is the value needed to accommodate the largest integer pos value
1383          --  in the range of the subtype + 1 for the space at the start. We
1384          --  build:
1385
1386          --     Tnn : constant Integer := Rtyp'Pos (Ptyp'Last)
1387
1388          --  and replace the expression by
1389
1390          --     (if Ptyp'Range_Length = 0 then 0
1391          --      else (if Tnn < 10 then 2
1392          --            else (if Tnn < 100 then 3
1393          --                  ...
1394          --                      else n)))...
1395
1396          --  where n is equal to Rtyp'Pos (Ptyp'Last) + 1
1397
1398          --  Note: The above processing is in accordance with the intent of
1399          --  the RM, which is that Width should be related to the impl-defined
1400          --  behavior of Image. It is not clear what this means if Image is
1401          --  not defined (as in the configurable run-time case for GNAT) and
1402          --  gives an error at compile time.
1403
1404          --  We choose in this case to just go ahead and implement Width the
1405          --  same way, returning what Image would have returned if it has been
1406          --  available in the configurable run-time library.
1407
1408          if Discard_Names (Rtyp) then
1409             declare
1410                Tnn   : constant Entity_Id := Make_Temporary (Loc, 'T');
1411                Cexpr : Node_Id;
1412                P     : Int;
1413                M     : Int;
1414                K     : Int;
1415
1416             begin
1417                Insert_Action (N,
1418                  Make_Object_Declaration (Loc,
1419                    Defining_Identifier => Tnn,
1420                    Constant_Present    => True,
1421                    Object_Definition   =>
1422                      New_Occurrence_Of (Standard_Integer, Loc),
1423                    Expression =>
1424                      Make_Attribute_Reference (Loc,
1425                        Prefix         => New_Occurrence_Of (Rtyp, Loc),
1426                        Attribute_Name => Name_Pos,
1427                        Expressions    => New_List (
1428                          Convert_To (Rtyp,
1429                            Make_Attribute_Reference (Loc,
1430                              Prefix         => New_Occurrence_Of (Ptyp, Loc),
1431                              Attribute_Name => Name_Last))))));
1432
1433                --  OK, now we need to build the if expression. First get the
1434                --  value of M, the largest possible value needed.
1435
1436                P := UI_To_Int
1437                       (Enumeration_Pos (Entity (Type_High_Bound (Rtyp))));
1438
1439                K := 1;
1440                M := 1;
1441                while M < P loop
1442                   M := M * 10;
1443                   K := K + 1;
1444                end loop;
1445
1446                --  Build inner else
1447
1448                Cexpr := Make_Integer_Literal (Loc, K);
1449
1450                --  Wrap in inner if's until counted down to 2
1451
1452                while K > 2 loop
1453                   M := M / 10;
1454                   K := K - 1;
1455
1456                   Cexpr :=
1457                     Make_If_Expression (Loc,
1458                       Expressions => New_List (
1459                         Make_Op_Lt (Loc,
1460                           Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
1461                           Right_Opnd => Make_Integer_Literal (Loc, M)),
1462                         Make_Integer_Literal (Loc, K),
1463                         Cexpr));
1464                end loop;
1465
1466                --  Add initial comparison for null range and we are done, so
1467                --  rewrite the attribute occurrence with this expression.
1468
1469                Rewrite (N,
1470                  Convert_To (Typ,
1471                    Make_If_Expression (Loc,
1472                      Expressions => New_List (
1473                        Make_Op_Eq (Loc,
1474                          Left_Opnd  =>
1475                            Make_Attribute_Reference (Loc,
1476                              Prefix         => New_Occurrence_Of (Ptyp, Loc),
1477                              Attribute_Name => Name_Range_Length),
1478                          Right_Opnd => Make_Integer_Literal (Loc, 0)),
1479                        Make_Integer_Literal (Loc, 0),
1480                        Cexpr))));
1481
1482                Analyze_And_Resolve (N, Typ);
1483                return;
1484             end;
1485          end if;
1486
1487          --  Normal case, not Discard_Names
1488
1489          Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1490
1491          case Attr is
1492             when Normal =>
1493                if Ttyp = Standard_Integer_8 then
1494                   XX := RE_Width_Enumeration_8;
1495                elsif Ttyp = Standard_Integer_16 then
1496                   XX := RE_Width_Enumeration_16;
1497                else
1498                   XX := RE_Width_Enumeration_32;
1499                end if;
1500
1501             when Wide =>
1502                if Ttyp = Standard_Integer_8 then
1503                   XX := RE_Wide_Width_Enumeration_8;
1504                elsif Ttyp = Standard_Integer_16 then
1505                   XX := RE_Wide_Width_Enumeration_16;
1506                else
1507                   XX := RE_Wide_Width_Enumeration_32;
1508                end if;
1509
1510             when Wide_Wide =>
1511                if Ttyp = Standard_Integer_8 then
1512                   XX := RE_Wide_Wide_Width_Enumeration_8;
1513                elsif Ttyp = Standard_Integer_16 then
1514                   XX := RE_Wide_Wide_Width_Enumeration_16;
1515                else
1516                   XX := RE_Wide_Wide_Width_Enumeration_32;
1517                end if;
1518          end case;
1519
1520          Arglist :=
1521            New_List (
1522              New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
1523
1524              Make_Attribute_Reference (Loc,
1525                Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1526                Attribute_Name => Name_Address),
1527
1528              Make_Attribute_Reference (Loc,
1529                Prefix => New_Occurrence_Of (Ptyp, Loc),
1530                Attribute_Name => Name_Pos,
1531
1532                Expressions => New_List (
1533                  Make_Attribute_Reference (Loc,
1534                    Prefix => New_Occurrence_Of (Ptyp, Loc),
1535                    Attribute_Name => Name_First))),
1536
1537              Make_Attribute_Reference (Loc,
1538                Prefix => New_Occurrence_Of (Ptyp, Loc),
1539                Attribute_Name => Name_Pos,
1540
1541                Expressions => New_List (
1542                  Make_Attribute_Reference (Loc,
1543                    Prefix => New_Occurrence_Of (Ptyp, Loc),
1544                    Attribute_Name => Name_Last))));
1545
1546          Rewrite (N,
1547            Convert_To (Typ,
1548              Make_Function_Call (Loc,
1549                Name => New_Occurrence_Of (RTE (XX), Loc),
1550                Parameter_Associations => Arglist)));
1551
1552          Analyze_And_Resolve (N, Typ);
1553          return;
1554       end if;
1555
1556       --  If we fall through XX and YY are set
1557
1558       Arglist := New_List (
1559         Convert_To (YY,
1560           Make_Attribute_Reference (Loc,
1561             Prefix => New_Occurrence_Of (Ptyp, Loc),
1562             Attribute_Name => Name_First)),
1563
1564         Convert_To (YY,
1565           Make_Attribute_Reference (Loc,
1566             Prefix => New_Occurrence_Of (Ptyp, Loc),
1567             Attribute_Name => Name_Last)));
1568
1569       Rewrite (N,
1570         Convert_To (Typ,
1571           Make_Function_Call (Loc,
1572             Name => New_Occurrence_Of (RTE (XX), Loc),
1573             Parameter_Associations => Arglist)));
1574
1575       Analyze_And_Resolve (N, Typ);
1576    end Expand_Width_Attribute;
1577
1578    -----------------------
1579    -- Has_Decimal_Small --
1580    -----------------------
1581
1582    function Has_Decimal_Small (E : Entity_Id) return Boolean is
1583    begin
1584       return Is_Decimal_Fixed_Point_Type (E)
1585         or else
1586           (Is_Ordinary_Fixed_Point_Type (E)
1587              and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1);
1588    end Has_Decimal_Small;
1589
1590    --------------------------
1591    -- Rewrite_Object_Image --
1592    --------------------------
1593
1594    procedure Rewrite_Object_Image
1595      (N         : Node_Id;
1596       Pref      : Entity_Id;
1597       Attr_Name : Name_Id;
1598       Str_Typ   : Entity_Id)
1599    is
1600    begin
1601       Rewrite (N,
1602         Make_Attribute_Reference (Sloc (N),
1603           Prefix         => New_Occurrence_Of (Etype (Pref), Sloc (N)),
1604           Attribute_Name => Attr_Name,
1605           Expressions    => New_List (Relocate_Node (Pref))));
1606
1607       Analyze_And_Resolve (N, Str_Typ);
1608    end Rewrite_Object_Image;
1609 end Exp_Imgv;