1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2017, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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;
32 with Namet; use Namet;
33 with Nmake; use Nmake;
34 with Nlists; use Nlists;
36 with Rtsfind; use Rtsfind;
37 with Sem_Aux; use Sem_Aux;
38 with Sem_Res; use Sem_Res;
39 with Sinfo; use Sinfo;
40 with Snames; use Snames;
41 with Stand; use Stand;
42 with Stringt; use Stringt;
43 with Tbuild; use Tbuild;
44 with Ttypes; use Ttypes;
45 with Uintp; use Uintp;
46 with Urealp; use Urealp;
48 package body Exp_Imgv is
50 function Has_Decimal_Small (E : Entity_Id) return Boolean;
51 -- Applies to all entities. True for a Decimal_Fixed_Point_Type, or an
52 -- Ordinary_Fixed_Point_Type with a small that is a negative power of ten.
53 -- Shouldn't this be in einfo.adb or sem_aux.adb???
55 ------------------------------------
56 -- Build_Enumeration_Image_Tables --
57 ------------------------------------
59 procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is
60 Loc : constant Source_Ptr := Sloc (E);
71 -- Nothing to do for other than a root enumeration type
73 if E /= Root_Type (E) then
76 -- Nothing to do if pragma Discard_Names applies
78 elsif Discard_Names (E) then
82 -- Otherwise tables need constructing
86 Lit := First_Literal (E);
92 Make_Integer_Literal (Loc, UI_From_Int (Len)));
97 Get_Unqualified_Decoded_Name_String (Chars (Lit));
99 if Name_Buffer (1) /= ''' then
100 Set_Casing (All_Upper_Case);
103 Store_String_Chars (Name_Buffer (1 .. Name_Len));
104 Len := Len + Int (Name_Len);
108 if Len < Int (2 ** (8 - 1)) then
109 Ityp := Standard_Integer_8;
110 elsif Len < Int (2 ** (16 - 1)) then
111 Ityp := Standard_Integer_16;
113 Ityp := Standard_Integer_32;
119 Make_Defining_Identifier (Loc,
120 Chars => New_External_Name (Chars (E), 'S'));
123 Make_Defining_Identifier (Loc,
124 Chars => New_External_Name (Chars (E), 'N'));
126 Set_Lit_Strings (E, Estr);
127 Set_Lit_Indexes (E, Eind);
131 Make_Object_Declaration (Loc,
132 Defining_Identifier => Estr,
133 Constant_Present => True,
135 New_Occurrence_Of (Standard_String, Loc),
137 Make_String_Literal (Loc,
140 Make_Object_Declaration (Loc,
141 Defining_Identifier => Eind,
142 Constant_Present => True,
145 Make_Constrained_Array_Definition (Loc,
146 Discrete_Subtype_Definitions => New_List (
148 Low_Bound => Make_Integer_Literal (Loc, 0),
149 High_Bound => Make_Integer_Literal (Loc, Nlit))),
150 Component_Definition =>
151 Make_Component_Definition (Loc,
152 Aliased_Present => False,
153 Subtype_Indication => New_Occurrence_Of (Ityp, Loc))),
157 Expressions => Ind))),
158 Suppress => All_Checks);
159 end Build_Enumeration_Image_Tables;
161 ----------------------------
162 -- Expand_Image_Attribute --
163 ----------------------------
165 -- For all cases other than user defined enumeration types, the scheme
166 -- is as follows. First we insert the following code:
168 -- Snn : String (1 .. rt'Width);
170 -- Image_xx (tv, Snn, Pnn [,pm]);
172 -- and then Expr is replaced by Snn (1 .. Pnn)
174 -- In the above expansion:
176 -- rt is the root type of the expression
177 -- tv is the expression with the value, usually a type conversion
178 -- pm is an extra parameter present in some cases
180 -- The following table shows tv, xx, and (if used) pm for the various
181 -- possible types of the argument:
183 -- For types whose root type is Character
185 -- tv = Character (Expr)
187 -- For types whose root type is Boolean
189 -- tv = Boolean (Expr)
191 -- For signed integer types with size <= Integer'Size
193 -- tv = Integer (Expr)
195 -- For other signed integer types
196 -- xx = Long_Long_Integer
197 -- tv = Long_Long_Integer (Expr)
199 -- For modular types with modulus <= System.Unsigned_Types.Unsigned
201 -- tv = System.Unsigned_Types.Unsigned (Expr)
203 -- For other modular integer types
204 -- xx = Long_Long_Unsigned
205 -- tv = System.Unsigned_Types.Long_Long_Unsigned (Expr)
207 -- For types whose root type is Wide_Character
208 -- xx = Wide_Character
209 -- tv = Wide_Character (Expr)
210 -- pm = Boolean, true if Ada 2005 mode, False otherwise
212 -- For types whose root type is Wide_Wide_Character
213 -- xx = Wide_Wide_Character
214 -- tv = Wide_Wide_Character (Expr)
216 -- For floating-point types
217 -- xx = Floating_Point
218 -- tv = Long_Long_Float (Expr)
219 -- pm = typ'Digits (typ = subtype of expression)
221 -- For ordinary fixed-point types
222 -- xx = Ordinary_Fixed_Point
223 -- tv = Long_Long_Float (Expr)
224 -- pm = typ'Aft (typ = subtype of expression)
226 -- For decimal fixed-point types with size = Integer'Size
228 -- tv = Integer (Expr)
229 -- pm = typ'Scale (typ = subtype of expression)
231 -- For decimal fixed-point types with size > Integer'Size
232 -- xx = Long_Long_Decimal
233 -- tv = Long_Long_Integer?(Expr) [convert with no scaling]
234 -- pm = typ'Scale (typ = subtype of expression)
236 -- For enumeration types other than those declared packages Standard
237 -- or System, Snn, Pnn, are expanded as above, but the call looks like:
239 -- Image_Enumeration_NN (rt'Pos (X), Snn, Pnn, typS, typI'Address)
241 -- where rt is the root type of the expression, and typS and typI are
242 -- the entities constructed as described in the spec for the procedure
243 -- Build_Enumeration_Image_Tables and NN is 32/16/8 depending on the
244 -- element type of Lit_Indexes. The rewriting of the expression to
245 -- Snn (1 .. Pnn) then occurs as in the other cases. A special case is
246 -- when pragma Discard_Names applies, in which case we replace expr by:
248 -- (rt'Pos (expr))'Img
250 -- So that the result is a space followed by the decimal value for the
251 -- position of the enumeration value in the enumeration type.
253 procedure Expand_Image_Attribute (N : Node_Id) is
254 Loc : constant Source_Ptr := Sloc (N);
255 Exprs : constant List_Id := Expressions (N);
256 Pref : constant Node_Id := Prefix (N);
257 Ptyp : constant Entity_Id := Entity (Pref);
258 Rtyp : constant Entity_Id := Root_Type (Ptyp);
259 Expr : constant Node_Id := Relocate_Node (First (Exprs));
263 Proc_Ent : Entity_Id;
267 -- List of arguments for run-time procedure call
270 -- List of actions to be inserted
272 Snn : constant Entity_Id := Make_Temporary (Loc, 'S');
273 Pnn : constant Entity_Id := Make_Temporary (Loc, 'P');
276 -- Build declarations of Snn and Pnn to be inserted
278 Ins_List := New_List (
280 -- Snn : String (1 .. typ'Width);
282 Make_Object_Declaration (Loc,
283 Defining_Identifier => Snn,
285 Make_Subtype_Indication (Loc,
286 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
288 Make_Index_Or_Discriminant_Constraint (Loc,
289 Constraints => New_List (
291 Low_Bound => Make_Integer_Literal (Loc, 1),
293 Make_Attribute_Reference (Loc,
294 Prefix => New_Occurrence_Of (Rtyp, Loc),
295 Attribute_Name => Name_Width)))))),
299 Make_Object_Declaration (Loc,
300 Defining_Identifier => Pnn,
301 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)));
303 -- Set Imid (RE_Id of procedure to call), and Tent, target for the
304 -- type conversion of the first argument for all possibilities.
308 if Rtyp = Standard_Boolean then
309 Imid := RE_Image_Boolean;
312 -- For standard character, we have to select the version which handles
313 -- soft hyphen correctly, based on the version of Ada in use (this is
314 -- ugly, but we have no choice).
316 elsif Rtyp = Standard_Character then
317 if Ada_Version < Ada_2005 then
318 Imid := RE_Image_Character;
320 Imid := RE_Image_Character_05;
325 elsif Rtyp = Standard_Wide_Character then
326 Imid := RE_Image_Wide_Character;
329 elsif Rtyp = Standard_Wide_Wide_Character then
330 Imid := RE_Image_Wide_Wide_Character;
333 elsif Is_Signed_Integer_Type (Rtyp) then
334 if Esize (Rtyp) <= Esize (Standard_Integer) then
335 Imid := RE_Image_Integer;
336 Tent := Standard_Integer;
338 Imid := RE_Image_Long_Long_Integer;
339 Tent := Standard_Long_Long_Integer;
342 elsif Is_Modular_Integer_Type (Rtyp) then
343 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
344 Imid := RE_Image_Unsigned;
345 Tent := RTE (RE_Unsigned);
347 Imid := RE_Image_Long_Long_Unsigned;
348 Tent := RTE (RE_Long_Long_Unsigned);
351 elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then
352 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
353 Imid := RE_Image_Decimal;
354 Tent := Standard_Integer;
356 Imid := RE_Image_Long_Long_Decimal;
357 Tent := Standard_Long_Long_Integer;
360 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
361 Imid := RE_Image_Ordinary_Fixed_Point;
362 Tent := Standard_Long_Long_Float;
364 elsif Is_Floating_Point_Type (Rtyp) then
365 Imid := RE_Image_Floating_Point;
366 Tent := Standard_Long_Long_Float;
368 -- Only other possibility is user defined enumeration type
371 if Discard_Names (First_Subtype (Ptyp))
372 or else No (Lit_Strings (Root_Type (Ptyp)))
374 -- When pragma Discard_Names applies to the first subtype, build
375 -- (Pref'Pos (Expr))'Img.
378 Make_Attribute_Reference (Loc,
380 Make_Attribute_Reference (Loc,
382 Attribute_Name => Name_Pos,
383 Expressions => New_List (Expr)),
386 Analyze_And_Resolve (N, Standard_String);
390 -- Here for enumeration type case
392 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
394 if Ttyp = Standard_Integer_8 then
395 Imid := RE_Image_Enumeration_8;
397 elsif Ttyp = Standard_Integer_16 then
398 Imid := RE_Image_Enumeration_16;
401 Imid := RE_Image_Enumeration_32;
404 -- Apply a validity check, since it is a bit drastic to get a
405 -- completely junk image value for an invalid value.
407 if not Expr_Known_Valid (Expr) then
408 Insert_Valid_Check (Expr);
415 -- Build first argument for call
418 Arg_List := New_List (
419 Make_Attribute_Reference (Loc,
420 Attribute_Name => Name_Pos,
421 Prefix => New_Occurrence_Of (Ptyp, Loc),
422 Expressions => New_List (Expr)));
425 Arg_List := New_List (Convert_To (Tent, Expr));
428 -- Append Snn, Pnn arguments
430 Append_To (Arg_List, New_Occurrence_Of (Snn, Loc));
431 Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc));
433 -- Get entity of procedure to call
435 Proc_Ent := RTE (Imid);
437 -- If the procedure entity is empty, that means we have a case in
438 -- no run time mode where the operation is not allowed, and an
439 -- appropriate diagnostic has already been issued.
441 if No (Proc_Ent) then
445 -- Otherwise complete preparation of arguments for run-time call
447 -- Add extra arguments for Enumeration case
450 Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
452 Make_Attribute_Reference (Loc,
453 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
454 Attribute_Name => Name_Address));
456 -- For floating-point types, append Digits argument
458 elsif Is_Floating_Point_Type (Rtyp) then
460 Make_Attribute_Reference (Loc,
461 Prefix => New_Occurrence_Of (Ptyp, Loc),
462 Attribute_Name => Name_Digits));
464 -- For ordinary fixed-point types, append Aft parameter
466 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
468 Make_Attribute_Reference (Loc,
469 Prefix => New_Occurrence_Of (Ptyp, Loc),
470 Attribute_Name => Name_Aft));
472 if Has_Decimal_Small (Rtyp) then
473 Set_Conversion_OK (First (Arg_List));
474 Set_Etype (First (Arg_List), Tent);
477 -- For decimal, append Scale and also set to do literal conversion
479 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
481 Make_Attribute_Reference (Loc,
482 Prefix => New_Occurrence_Of (Ptyp, Loc),
483 Attribute_Name => Name_Scale));
485 Set_Conversion_OK (First (Arg_List));
486 Set_Etype (First (Arg_List), Tent);
488 -- For Wide_Character, append Ada 2005 indication
490 elsif Rtyp = Standard_Wide_Character then
493 (Boolean_Literals (Ada_Version >= Ada_2005), Loc));
496 -- Now append the procedure call to the insert list
499 Make_Procedure_Call_Statement (Loc,
500 Name => New_Occurrence_Of (Proc_Ent, Loc),
501 Parameter_Associations => Arg_List));
503 -- Insert declarations of Snn, Pnn, and the procedure call. We suppress
504 -- checks because we are sure that everything is in range at this stage.
506 Insert_Actions (N, Ins_List, Suppress => All_Checks);
508 -- Final step is to rewrite the expression as a slice and analyze,
509 -- again with no checks, since we are sure that everything is OK.
513 Prefix => New_Occurrence_Of (Snn, Loc),
516 Low_Bound => Make_Integer_Literal (Loc, 1),
517 High_Bound => New_Occurrence_Of (Pnn, Loc))));
519 Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
520 end Expand_Image_Attribute;
522 ----------------------------
523 -- Expand_Value_Attribute --
524 ----------------------------
526 -- For scalar types derived from Boolean, Character and integer types
527 -- in package Standard, typ'Value (X) expands into:
529 -- btyp (Value_xx (X))
531 -- where btyp is he base type of the prefix
533 -- For types whose root type is Character
536 -- For types whose root type is Wide_Character
537 -- xx = Wide_Character
539 -- For types whose root type is Wide_Wide_Character
540 -- xx = Wide_Wide_Character
542 -- For types whose root type is Boolean
545 -- For signed integer types with size <= Integer'Size
548 -- For other signed integer types
549 -- xx = Long_Long_Integer
551 -- For modular types with modulus <= System.Unsigned_Types.Unsigned
554 -- For other modular integer types
555 -- xx = Long_Long_Unsigned
557 -- For floating-point types and ordinary fixed-point types
560 -- For Wide_[Wide_]Character types, typ'Value (X) expands into:
562 -- btyp (Value_xx (X, EM))
564 -- where btyp is the base type of the prefix, and EM is the encoding method
566 -- For decimal types with size <= Integer'Size, typ'Value (X)
569 -- btyp?(Value_Decimal (X, typ'Scale));
571 -- For all other decimal types, typ'Value (X) expands into
573 -- btyp?(Value_Long_Long_Decimal (X, typ'Scale))
575 -- For enumeration types other than those derived from types Boolean,
576 -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
578 -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
580 -- where typS and typI and the Lit_Strings and Lit_Indexes entities
581 -- from T's root type entity, and Num is Enum'Pos (Enum'Last). The
582 -- Value_Enumeration_NN function will search the tables looking for
583 -- X and return the position number in the table if found which is
584 -- used to provide the result of 'Value (using Enum'Val). If the
585 -- value is not found Constraint_Error is raised. The suffix _NN
586 -- depends on the element type of typI.
588 procedure Expand_Value_Attribute (N : Node_Id) is
589 Loc : constant Source_Ptr := Sloc (N);
590 Typ : constant Entity_Id := Etype (N);
591 Btyp : constant Entity_Id := Base_Type (Typ);
592 Rtyp : constant Entity_Id := Root_Type (Typ);
593 Exprs : constant List_Id := Expressions (N);
602 if Rtyp = Standard_Character then
603 Vid := RE_Value_Character;
605 elsif Rtyp = Standard_Boolean then
606 Vid := RE_Value_Boolean;
608 elsif Rtyp = Standard_Wide_Character then
609 Vid := RE_Value_Wide_Character;
612 Make_Integer_Literal (Loc,
613 Intval => Int (Wide_Character_Encoding_Method)));
615 elsif Rtyp = Standard_Wide_Wide_Character then
616 Vid := RE_Value_Wide_Wide_Character;
619 Make_Integer_Literal (Loc,
620 Intval => Int (Wide_Character_Encoding_Method)));
622 elsif Rtyp = Base_Type (Standard_Short_Short_Integer)
623 or else Rtyp = Base_Type (Standard_Short_Integer)
624 or else Rtyp = Base_Type (Standard_Integer)
626 Vid := RE_Value_Integer;
628 elsif Is_Signed_Integer_Type (Rtyp) then
629 Vid := RE_Value_Long_Long_Integer;
631 elsif Is_Modular_Integer_Type (Rtyp) then
632 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
633 Vid := RE_Value_Unsigned;
635 Vid := RE_Value_Long_Long_Unsigned;
638 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
639 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
640 Vid := RE_Value_Decimal;
642 Vid := RE_Value_Long_Long_Decimal;
646 Make_Attribute_Reference (Loc,
647 Prefix => New_Occurrence_Of (Typ, Loc),
648 Attribute_Name => Name_Scale));
652 Make_Function_Call (Loc,
653 Name => New_Occurrence_Of (RTE (Vid), Loc),
654 Parameter_Associations => Args)));
657 Analyze_And_Resolve (N, Btyp);
660 elsif Is_Real_Type (Rtyp) then
661 Vid := RE_Value_Real;
663 -- Only other possibility is user defined enumeration type
666 pragma Assert (Is_Enumeration_Type (Rtyp));
668 -- Case of pragma Discard_Names, transform the Value
669 -- attribute to Btyp'Val (Long_Long_Integer'Value (Args))
671 if Discard_Names (First_Subtype (Typ))
672 or else No (Lit_Strings (Rtyp))
675 Make_Attribute_Reference (Loc,
676 Prefix => New_Occurrence_Of (Btyp, Loc),
677 Attribute_Name => Name_Val,
678 Expressions => New_List (
679 Make_Attribute_Reference (Loc,
681 New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
682 Attribute_Name => Name_Value,
683 Expressions => Args))));
685 Analyze_And_Resolve (N, Btyp);
687 -- Here for normal case where we have enumeration tables, this
690 -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
693 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
695 if Ttyp = Standard_Integer_8 then
696 Func := RE_Value_Enumeration_8;
697 elsif Ttyp = Standard_Integer_16 then
698 Func := RE_Value_Enumeration_16;
700 Func := RE_Value_Enumeration_32;
704 Make_Attribute_Reference (Loc,
705 Prefix => New_Occurrence_Of (Rtyp, Loc),
706 Attribute_Name => Name_Pos,
707 Expressions => New_List (
708 Make_Attribute_Reference (Loc,
709 Prefix => New_Occurrence_Of (Rtyp, Loc),
710 Attribute_Name => Name_Last))));
713 Make_Attribute_Reference (Loc,
714 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
715 Attribute_Name => Name_Address));
718 New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
721 Make_Attribute_Reference (Loc,
722 Prefix => New_Occurrence_Of (Typ, Loc),
723 Attribute_Name => Name_Val,
724 Expressions => New_List (
725 Make_Function_Call (Loc,
727 New_Occurrence_Of (RTE (Func), Loc),
728 Parameter_Associations => Args))));
730 Analyze_And_Resolve (N, Btyp);
736 -- Fall through for all cases except user defined enumeration type
737 -- and decimal types, with Vid set to the Id of the entity for the
738 -- Value routine and Args set to the list of parameters for the call.
740 -- Compiling package Ada.Tags under No_Run_Time_Mode we disable the
741 -- expansion of the attribute into the function call statement to avoid
742 -- generating spurious errors caused by the use of Integer_Address'Value
743 -- in our implementation of Ada.Tags.Internal_Tag
745 -- Seems like a bit of a odd approach, there should be a better way ???
747 -- There is a better way, test RTE_Available ???
750 and then Rtyp = RTE (RE_Integer_Address)
751 and then RTU_Loaded (Ada_Tags)
752 and then Cunit_Entity (Current_Sem_Unit)
753 = Body_Entity (RTU_Entity (Ada_Tags))
756 Unchecked_Convert_To (Rtyp,
757 Make_Integer_Literal (Loc, Uint_0)));
761 Make_Function_Call (Loc,
762 Name => New_Occurrence_Of (RTE (Vid), Loc),
763 Parameter_Associations => Args)));
766 Analyze_And_Resolve (N, Btyp);
767 end Expand_Value_Attribute;
769 ---------------------------------
770 -- Expand_Wide_Image_Attribute --
771 ---------------------------------
773 -- We expand typ'Wide_Image (X) as follows. First we insert this code:
775 -- Rnn : Wide_String (1 .. rt'Wide_Width);
777 -- String_To_Wide_String
778 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
780 -- where rt is the root type of the prefix type
782 -- Now we replace the Wide_Image reference by
786 -- This works in all cases because String_To_Wide_String converts any
787 -- wide character escape sequences resulting from the Image call to the
788 -- proper Wide_Character equivalent
790 -- not quite right for typ = Wide_Character ???
792 procedure Expand_Wide_Image_Attribute (N : Node_Id) is
793 Loc : constant Source_Ptr := Sloc (N);
794 Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N)));
795 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
796 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
799 Insert_Actions (N, New_List (
801 -- Rnn : Wide_String (1 .. base_typ'Width);
803 Make_Object_Declaration (Loc,
804 Defining_Identifier => Rnn,
806 Make_Subtype_Indication (Loc,
808 New_Occurrence_Of (Standard_Wide_String, Loc),
810 Make_Index_Or_Discriminant_Constraint (Loc,
811 Constraints => New_List (
813 Low_Bound => Make_Integer_Literal (Loc, 1),
815 Make_Attribute_Reference (Loc,
816 Prefix => New_Occurrence_Of (Rtyp, Loc),
817 Attribute_Name => Name_Wide_Width)))))),
821 Make_Object_Declaration (Loc,
822 Defining_Identifier => Lnn,
823 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
825 -- String_To_Wide_String
826 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
828 Make_Procedure_Call_Statement (Loc,
830 New_Occurrence_Of (RTE (RE_String_To_Wide_String), Loc),
832 Parameter_Associations => New_List (
833 Make_Attribute_Reference (Loc,
834 Prefix => Prefix (N),
835 Attribute_Name => Name_Image,
836 Expressions => Expressions (N)),
837 New_Occurrence_Of (Rnn, Loc),
838 New_Occurrence_Of (Lnn, Loc),
839 Make_Integer_Literal (Loc,
840 Intval => Int (Wide_Character_Encoding_Method))))),
842 -- Suppress checks because we know everything is properly in range
844 Suppress => All_Checks);
846 -- Final step is to rewrite the expression as a slice and analyze,
847 -- again with no checks, since we are sure that everything is OK.
851 Prefix => New_Occurrence_Of (Rnn, Loc),
854 Low_Bound => Make_Integer_Literal (Loc, 1),
855 High_Bound => New_Occurrence_Of (Lnn, Loc))));
857 Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks);
858 end Expand_Wide_Image_Attribute;
860 --------------------------------------
861 -- Expand_Wide_Wide_Image_Attribute --
862 --------------------------------------
864 -- We expand typ'Wide_Wide_Image (X) as follows. First we insert this code:
866 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
868 -- String_To_Wide_Wide_String
869 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
871 -- where rt is the root type of the prefix type
873 -- Now we replace the Wide_Wide_Image reference by
877 -- This works in all cases because String_To_Wide_Wide_String converts any
878 -- wide character escape sequences resulting from the Image call to the
879 -- proper Wide_Wide_Character equivalent
881 -- not quite right for typ = Wide_Wide_Character ???
883 procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is
884 Loc : constant Source_Ptr := Sloc (N);
885 Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N)));
887 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
888 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
891 Insert_Actions (N, New_List (
893 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
895 Make_Object_Declaration (Loc,
896 Defining_Identifier => Rnn,
898 Make_Subtype_Indication (Loc,
900 New_Occurrence_Of (Standard_Wide_Wide_String, Loc),
902 Make_Index_Or_Discriminant_Constraint (Loc,
903 Constraints => New_List (
905 Low_Bound => Make_Integer_Literal (Loc, 1),
907 Make_Attribute_Reference (Loc,
908 Prefix => New_Occurrence_Of (Rtyp, Loc),
909 Attribute_Name => Name_Wide_Wide_Width)))))),
913 Make_Object_Declaration (Loc,
914 Defining_Identifier => Lnn,
915 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
917 -- String_To_Wide_Wide_String
918 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
920 Make_Procedure_Call_Statement (Loc,
922 New_Occurrence_Of (RTE (RE_String_To_Wide_Wide_String), Loc),
924 Parameter_Associations => New_List (
925 Make_Attribute_Reference (Loc,
926 Prefix => Prefix (N),
927 Attribute_Name => Name_Image,
928 Expressions => Expressions (N)),
929 New_Occurrence_Of (Rnn, Loc),
930 New_Occurrence_Of (Lnn, Loc),
931 Make_Integer_Literal (Loc,
932 Intval => Int (Wide_Character_Encoding_Method))))),
934 -- Suppress checks because we know everything is properly in range
936 Suppress => All_Checks);
938 -- Final step is to rewrite the expression as a slice and analyze,
939 -- again with no checks, since we are sure that everything is OK.
943 Prefix => New_Occurrence_Of (Rnn, Loc),
946 Low_Bound => Make_Integer_Literal (Loc, 1),
947 High_Bound => New_Occurrence_Of (Lnn, Loc))));
950 (N, Standard_Wide_Wide_String, Suppress => All_Checks);
951 end Expand_Wide_Wide_Image_Attribute;
953 ----------------------------
954 -- Expand_Width_Attribute --
955 ----------------------------
957 -- The processing here also handles the case of Wide_[Wide_]Width. With the
958 -- exceptions noted, the processing is identical
960 -- For scalar types derived from Boolean, character and integer types
961 -- in package Standard. Note that the Width attribute is computed at
962 -- compile time for all cases except those involving non-static sub-
963 -- types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
965 -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
969 -- For types whose root type is Character
970 -- xx = Width_Character
973 -- For types whose root type is Wide_Character
974 -- xx = Wide_Width_Character
977 -- For types whose root type is Wide_Wide_Character
978 -- xx = Wide_Wide_Width_Character
981 -- For types whose root type is Boolean
982 -- xx = Width_Boolean
985 -- For signed integer types
986 -- xx = Width_Long_Long_Integer
987 -- yy = Long_Long_Integer
989 -- For modular integer types
990 -- xx = Width_Long_Long_Unsigned
991 -- yy = Long_Long_Unsigned
993 -- For types derived from Wide_Character, typ'Width expands into
995 -- Result_Type (Width_Wide_Character (
996 -- Wide_Character (typ'First),
997 -- Wide_Character (typ'Last),
999 -- and typ'Wide_Width expands into:
1001 -- Result_Type (Wide_Width_Wide_Character (
1002 -- Wide_Character (typ'First),
1003 -- Wide_Character (typ'Last));
1005 -- and typ'Wide_Wide_Width expands into
1007 -- Result_Type (Wide_Wide_Width_Wide_Character (
1008 -- Wide_Character (typ'First),
1009 -- Wide_Character (typ'Last));
1011 -- For types derived from Wide_Wide_Character, typ'Width expands into
1013 -- Result_Type (Width_Wide_Wide_Character (
1014 -- Wide_Wide_Character (typ'First),
1015 -- Wide_Wide_Character (typ'Last),
1017 -- and typ'Wide_Width expands into:
1019 -- Result_Type (Wide_Width_Wide_Wide_Character (
1020 -- Wide_Wide_Character (typ'First),
1021 -- Wide_Wide_Character (typ'Last));
1023 -- and typ'Wide_Wide_Width expands into
1025 -- Result_Type (Wide_Wide_Width_Wide_Wide_Char (
1026 -- Wide_Wide_Character (typ'First),
1027 -- Wide_Wide_Character (typ'Last));
1029 -- For real types, typ'Width and typ'Wide_[Wide_]Width expand into
1031 -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
1033 -- where btyp is the base type. This looks recursive but it isn't
1034 -- because the base type is always static, and hence the expression
1035 -- in the else is reduced to an integer literal.
1037 -- For user defined enumeration types, typ'Width expands into
1039 -- Result_Type (Width_Enumeration_NN
1042 -- typ'Pos (typ'First),
1043 -- typ'Pos (Typ'Last)));
1045 -- and typ'Wide_Width expands into:
1047 -- Result_Type (Wide_Width_Enumeration_NN
1050 -- typ'Pos (typ'First),
1051 -- typ'Pos (Typ'Last))
1052 -- Wide_Character_Encoding_Method);
1054 -- and typ'Wide_Wide_Width expands into:
1056 -- Result_Type (Wide_Wide_Width_Enumeration_NN
1059 -- typ'Pos (typ'First),
1060 -- typ'Pos (Typ'Last))
1061 -- Wide_Character_Encoding_Method);
1063 -- where typS and typI are the enumeration image strings and indexes
1064 -- table, as described in Build_Enumeration_Image_Tables. NN is 8/16/32
1065 -- for depending on the element type for typI.
1067 -- Finally if Discard_Names is in effect for an enumeration type, then
1068 -- a special if expression is built that yields the space needed for the
1069 -- decimal representation of the largest pos value in the subtype. See
1070 -- code below for details.
1072 procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is
1073 Loc : constant Source_Ptr := Sloc (N);
1074 Typ : constant Entity_Id := Etype (N);
1075 Pref : constant Node_Id := Prefix (N);
1076 Ptyp : constant Entity_Id := Etype (Pref);
1077 Rtyp : constant Entity_Id := Root_Type (Ptyp);
1084 -- Types derived from Standard.Boolean
1086 if Rtyp = Standard_Boolean then
1087 XX := RE_Width_Boolean;
1090 -- Types derived from Standard.Character
1092 elsif Rtyp = Standard_Character then
1094 when Normal => XX := RE_Width_Character;
1095 when Wide => XX := RE_Wide_Width_Character;
1096 when Wide_Wide => XX := RE_Wide_Wide_Width_Character;
1101 -- Types derived from Standard.Wide_Character
1103 elsif Rtyp = Standard_Wide_Character then
1105 when Normal => XX := RE_Width_Wide_Character;
1106 when Wide => XX := RE_Wide_Width_Wide_Character;
1107 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character;
1112 -- Types derived from Standard.Wide_Wide_Character
1114 elsif Rtyp = Standard_Wide_Wide_Character then
1116 when Normal => XX := RE_Width_Wide_Wide_Character;
1117 when Wide => XX := RE_Wide_Width_Wide_Wide_Character;
1118 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char;
1123 -- Signed integer types
1125 elsif Is_Signed_Integer_Type (Rtyp) then
1126 XX := RE_Width_Long_Long_Integer;
1127 YY := Standard_Long_Long_Integer;
1129 -- Modular integer types
1131 elsif Is_Modular_Integer_Type (Rtyp) then
1132 XX := RE_Width_Long_Long_Unsigned;
1133 YY := RTE (RE_Long_Long_Unsigned);
1137 elsif Is_Real_Type (Rtyp) then
1139 Make_If_Expression (Loc,
1140 Expressions => New_List (
1144 Make_Attribute_Reference (Loc,
1145 Prefix => New_Occurrence_Of (Ptyp, Loc),
1146 Attribute_Name => Name_First),
1149 Make_Attribute_Reference (Loc,
1150 Prefix => New_Occurrence_Of (Ptyp, Loc),
1151 Attribute_Name => Name_Last)),
1153 Make_Integer_Literal (Loc, 0),
1155 Make_Attribute_Reference (Loc,
1156 Prefix => New_Occurrence_Of (Base_Type (Ptyp), Loc),
1157 Attribute_Name => Name_Width))));
1159 Analyze_And_Resolve (N, Typ);
1162 -- User defined enumeration types
1165 pragma Assert (Is_Enumeration_Type (Rtyp));
1167 -- Whenever pragma Discard_Names is in effect, the value we need
1168 -- is the value needed to accommodate the largest integer pos value
1169 -- in the range of the subtype + 1 for the space at the start. We
1172 -- Tnn : constant Integer := Rtyp'Pos (Ptyp'Last)
1174 -- and replace the expression by
1176 -- (if Ptyp'Range_Length = 0 then 0
1177 -- else (if Tnn < 10 then 2
1178 -- else (if Tnn < 100 then 3
1182 -- where n is equal to Rtyp'Pos (Ptyp'Last) + 1
1184 -- Note: The above processing is in accordance with the intent of
1185 -- the RM, which is that Width should be related to the impl-defined
1186 -- behavior of Image. It is not clear what this means if Image is
1187 -- not defined (as in the configurable run-time case for GNAT) and
1188 -- gives an error at compile time.
1190 -- We choose in this case to just go ahead and implement Width the
1191 -- same way, returning what Image would have returned if it has been
1192 -- available in the configurable run-time library.
1194 if Discard_Names (Rtyp) then
1196 Tnn : constant Entity_Id := Make_Temporary (Loc, 'T');
1204 Make_Object_Declaration (Loc,
1205 Defining_Identifier => Tnn,
1206 Constant_Present => True,
1207 Object_Definition =>
1208 New_Occurrence_Of (Standard_Integer, Loc),
1210 Make_Attribute_Reference (Loc,
1211 Prefix => New_Occurrence_Of (Rtyp, Loc),
1212 Attribute_Name => Name_Pos,
1213 Expressions => New_List (
1215 Make_Attribute_Reference (Loc,
1216 Prefix => New_Occurrence_Of (Ptyp, Loc),
1217 Attribute_Name => Name_Last))))));
1219 -- OK, now we need to build the if expression. First get the
1220 -- value of M, the largest possible value needed.
1223 (Enumeration_Pos (Entity (Type_High_Bound (Rtyp))));
1234 Cexpr := Make_Integer_Literal (Loc, K);
1236 -- Wrap in inner if's until counted down to 2
1243 Make_If_Expression (Loc,
1244 Expressions => New_List (
1246 Left_Opnd => New_Occurrence_Of (Tnn, Loc),
1247 Right_Opnd => Make_Integer_Literal (Loc, M)),
1248 Make_Integer_Literal (Loc, K),
1252 -- Add initial comparison for null range and we are done, so
1253 -- rewrite the attribute occurrence with this expression.
1257 Make_If_Expression (Loc,
1258 Expressions => New_List (
1261 Make_Attribute_Reference (Loc,
1262 Prefix => New_Occurrence_Of (Ptyp, Loc),
1263 Attribute_Name => Name_Range_Length),
1264 Right_Opnd => Make_Integer_Literal (Loc, 0)),
1265 Make_Integer_Literal (Loc, 0),
1268 Analyze_And_Resolve (N, Typ);
1273 -- Normal case, not Discard_Names
1275 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1279 if Ttyp = Standard_Integer_8 then
1280 XX := RE_Width_Enumeration_8;
1281 elsif Ttyp = Standard_Integer_16 then
1282 XX := RE_Width_Enumeration_16;
1284 XX := RE_Width_Enumeration_32;
1288 if Ttyp = Standard_Integer_8 then
1289 XX := RE_Wide_Width_Enumeration_8;
1290 elsif Ttyp = Standard_Integer_16 then
1291 XX := RE_Wide_Width_Enumeration_16;
1293 XX := RE_Wide_Width_Enumeration_32;
1297 if Ttyp = Standard_Integer_8 then
1298 XX := RE_Wide_Wide_Width_Enumeration_8;
1299 elsif Ttyp = Standard_Integer_16 then
1300 XX := RE_Wide_Wide_Width_Enumeration_16;
1302 XX := RE_Wide_Wide_Width_Enumeration_32;
1308 New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
1310 Make_Attribute_Reference (Loc,
1311 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1312 Attribute_Name => Name_Address),
1314 Make_Attribute_Reference (Loc,
1315 Prefix => New_Occurrence_Of (Ptyp, Loc),
1316 Attribute_Name => Name_Pos,
1318 Expressions => New_List (
1319 Make_Attribute_Reference (Loc,
1320 Prefix => New_Occurrence_Of (Ptyp, Loc),
1321 Attribute_Name => Name_First))),
1323 Make_Attribute_Reference (Loc,
1324 Prefix => New_Occurrence_Of (Ptyp, Loc),
1325 Attribute_Name => Name_Pos,
1327 Expressions => New_List (
1328 Make_Attribute_Reference (Loc,
1329 Prefix => New_Occurrence_Of (Ptyp, Loc),
1330 Attribute_Name => Name_Last))));
1334 Make_Function_Call (Loc,
1335 Name => New_Occurrence_Of (RTE (XX), Loc),
1336 Parameter_Associations => Arglist)));
1338 Analyze_And_Resolve (N, Typ);
1342 -- If we fall through XX and YY are set
1344 Arglist := New_List (
1346 Make_Attribute_Reference (Loc,
1347 Prefix => New_Occurrence_Of (Ptyp, Loc),
1348 Attribute_Name => Name_First)),
1351 Make_Attribute_Reference (Loc,
1352 Prefix => New_Occurrence_Of (Ptyp, Loc),
1353 Attribute_Name => Name_Last)));
1357 Make_Function_Call (Loc,
1358 Name => New_Occurrence_Of (RTE (XX), Loc),
1359 Parameter_Associations => Arglist)));
1361 Analyze_And_Resolve (N, Typ);
1362 end Expand_Width_Attribute;
1364 -----------------------
1365 -- Has_Decimal_Small --
1366 -----------------------
1368 function Has_Decimal_Small (E : Entity_Id) return Boolean is
1370 return Is_Decimal_Fixed_Point_Type (E)
1372 (Is_Ordinary_Fixed_Point_Type (E)
1373 and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1);
1374 end Has_Decimal_Small;