1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2010, 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:
250 procedure Expand_Image_Attribute (N : Node_Id) is
251 Loc : constant Source_Ptr := Sloc (N);
252 Exprs : constant List_Id := Expressions (N);
253 Pref : constant Node_Id := Prefix (N);
254 Ptyp : constant Entity_Id := Entity (Pref);
255 Rtyp : constant Entity_Id := Root_Type (Ptyp);
256 Expr : constant Node_Id := Relocate_Node (First (Exprs));
260 Proc_Ent : Entity_Id;
264 -- List of arguments for run-time procedure call
267 -- List of actions to be inserted
269 Snn : constant Entity_Id := Make_Temporary (Loc, 'S');
270 Pnn : constant Entity_Id := Make_Temporary (Loc, 'P');
273 -- Build declarations of Snn and Pnn to be inserted
275 Ins_List := New_List (
277 -- Snn : String (1 .. typ'Width);
279 Make_Object_Declaration (Loc,
280 Defining_Identifier => Snn,
282 Make_Subtype_Indication (Loc,
283 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
285 Make_Index_Or_Discriminant_Constraint (Loc,
286 Constraints => New_List (
288 Low_Bound => Make_Integer_Literal (Loc, 1),
290 Make_Attribute_Reference (Loc,
291 Prefix => New_Occurrence_Of (Rtyp, Loc),
292 Attribute_Name => Name_Width)))))),
296 Make_Object_Declaration (Loc,
297 Defining_Identifier => Pnn,
298 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)));
300 -- Set Imid (RE_Id of procedure to call), and Tent, target for the
301 -- type conversion of the first argument for all possibilities.
305 if Rtyp = Standard_Boolean then
306 Imid := RE_Image_Boolean;
309 -- For standard character, we have to select the version which handles
310 -- soft hyphen correctly, based on the version of Ada in use (ugly!)
312 elsif Rtyp = Standard_Character then
313 if Ada_Version < Ada_05 then
314 Imid := RE_Image_Character;
316 Imid := RE_Image_Character_05;
321 elsif Rtyp = Standard_Wide_Character then
322 Imid := RE_Image_Wide_Character;
325 elsif Rtyp = Standard_Wide_Wide_Character then
326 Imid := RE_Image_Wide_Wide_Character;
329 elsif Is_Signed_Integer_Type (Rtyp) then
330 if Esize (Rtyp) <= Esize (Standard_Integer) then
331 Imid := RE_Image_Integer;
332 Tent := Standard_Integer;
334 Imid := RE_Image_Long_Long_Integer;
335 Tent := Standard_Long_Long_Integer;
338 elsif Is_Modular_Integer_Type (Rtyp) then
339 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
340 Imid := RE_Image_Unsigned;
341 Tent := RTE (RE_Unsigned);
343 Imid := RE_Image_Long_Long_Unsigned;
344 Tent := RTE (RE_Long_Long_Unsigned);
347 elsif Is_Fixed_Point_Type (Rtyp) and then Has_Decimal_Small (Rtyp) then
348 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
349 Imid := RE_Image_Decimal;
350 Tent := Standard_Integer;
352 Imid := RE_Image_Long_Long_Decimal;
353 Tent := Standard_Long_Long_Integer;
356 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
357 Imid := RE_Image_Ordinary_Fixed_Point;
358 Tent := Standard_Long_Long_Float;
360 elsif Is_Floating_Point_Type (Rtyp) then
361 Imid := RE_Image_Floating_Point;
362 Tent := Standard_Long_Long_Float;
364 -- Only other possibility is user defined enumeration type
367 if Discard_Names (First_Subtype (Ptyp))
368 or else No (Lit_Strings (Root_Type (Ptyp)))
370 -- When pragma Discard_Names applies to the first subtype, build
374 Make_Attribute_Reference (Loc,
376 Make_Attribute_Reference (Loc,
378 Attribute_Name => Name_Pos,
379 Expressions => New_List (Expr)),
382 Analyze_And_Resolve (N, Standard_String);
386 -- Here for enumeration type case
388 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
390 if Ttyp = Standard_Integer_8 then
391 Imid := RE_Image_Enumeration_8;
393 elsif Ttyp = Standard_Integer_16 then
394 Imid := RE_Image_Enumeration_16;
397 Imid := RE_Image_Enumeration_32;
400 -- Apply a validity check, since it is a bit drastic to get a
401 -- completely junk image value for an invalid value.
403 if not Expr_Known_Valid (Expr) then
404 Insert_Valid_Check (Expr);
411 -- Build first argument for call
414 Arg_List := New_List (
415 Make_Attribute_Reference (Loc,
416 Attribute_Name => Name_Pos,
417 Prefix => New_Occurrence_Of (Ptyp, Loc),
418 Expressions => New_List (Expr)));
421 Arg_List := New_List (Convert_To (Tent, Expr));
424 -- Append Snn, Pnn arguments
426 Append_To (Arg_List, New_Occurrence_Of (Snn, Loc));
427 Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc));
429 -- Get entity of procedure to call
431 Proc_Ent := RTE (Imid);
433 -- If the procedure entity is empty, that means we have a case in
434 -- no run time mode where the operation is not allowed, and an
435 -- appropriate diagnostic has already been issued.
437 if No (Proc_Ent) then
441 -- Otherwise complete preparation of arguments for run-time call
443 -- Add extra arguments for Enumeration case
446 Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
448 Make_Attribute_Reference (Loc,
449 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
450 Attribute_Name => Name_Address));
452 -- For floating-point types, append Digits argument
454 elsif Is_Floating_Point_Type (Rtyp) then
456 Make_Attribute_Reference (Loc,
457 Prefix => New_Reference_To (Ptyp, Loc),
458 Attribute_Name => Name_Digits));
460 -- For ordinary fixed-point types, append Aft parameter
462 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
464 Make_Attribute_Reference (Loc,
465 Prefix => New_Reference_To (Ptyp, Loc),
466 Attribute_Name => Name_Aft));
468 if Has_Decimal_Small (Rtyp) then
469 Set_Conversion_OK (First (Arg_List));
470 Set_Etype (First (Arg_List), Tent);
473 -- For decimal, append Scale and also set to do literal conversion
475 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
477 Make_Attribute_Reference (Loc,
478 Prefix => New_Reference_To (Ptyp, Loc),
479 Attribute_Name => Name_Scale));
481 Set_Conversion_OK (First (Arg_List));
482 Set_Etype (First (Arg_List), Tent);
484 -- For Wide_Character, append Ada 2005 indication
486 elsif Rtyp = Standard_Wide_Character then
488 New_Reference_To (Boolean_Literals (Ada_Version >= Ada_05), Loc));
491 -- Now append the procedure call to the insert list
494 Make_Procedure_Call_Statement (Loc,
495 Name => New_Reference_To (Proc_Ent, Loc),
496 Parameter_Associations => Arg_List));
498 -- Insert declarations of Snn, Pnn, and the procedure call. We suppress
499 -- checks because we are sure that everything is in range at this stage.
501 Insert_Actions (N, Ins_List, Suppress => All_Checks);
503 -- Final step is to rewrite the expression as a slice and analyze,
504 -- again with no checks, since we are sure that everything is OK.
508 Prefix => New_Occurrence_Of (Snn, Loc),
511 Low_Bound => Make_Integer_Literal (Loc, 1),
512 High_Bound => New_Occurrence_Of (Pnn, Loc))));
514 Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
515 end Expand_Image_Attribute;
517 ----------------------------
518 -- Expand_Value_Attribute --
519 ----------------------------
521 -- For scalar types derived from Boolean, Character and integer types
522 -- in package Standard, typ'Value (X) expands into:
524 -- btyp (Value_xx (X))
526 -- where btyp is he base type of the prefix
528 -- For types whose root type is Character
531 -- For types whose root type is Wide_Character
532 -- xx = Wide_Character
534 -- For types whose root type is Wide_Wide_Character
535 -- xx = Wide_Wide_Character
537 -- For types whose root type is Boolean
540 -- For signed integer types with size <= Integer'Size
543 -- For other signed integer types
544 -- xx = Long_Long_Integer
546 -- For modular types with modulus <= System.Unsigned_Types.Unsigned
549 -- For other modular integer types
550 -- xx = Long_Long_Unsigned
552 -- For floating-point types and ordinary fixed-point types
555 -- For Wide_[Wide_]Character types, typ'Value (X) expands into:
557 -- btyp (Value_xx (X, EM))
559 -- where btyp is the base type of the prefix, and EM is the encoding method
561 -- For decimal types with size <= Integer'Size, typ'Value (X)
564 -- btyp?(Value_Decimal (X, typ'Scale));
566 -- For all other decimal types, typ'Value (X) expands into
568 -- btyp?(Value_Long_Long_Decimal (X, typ'Scale))
570 -- For enumeration types other than those derived from types Boolean,
571 -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
573 -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
575 -- where typS and typI and the Lit_Strings and Lit_Indexes entities
576 -- from T's root type entity, and Num is Enum'Pos (Enum'Last). The
577 -- Value_Enumeration_NN function will search the tables looking for
578 -- X and return the position number in the table if found which is
579 -- used to provide the result of 'Value (using Enum'Val). If the
580 -- value is not found Constraint_Error is raised. The suffix _NN
581 -- depends on the element type of typI.
583 procedure Expand_Value_Attribute (N : Node_Id) is
584 Loc : constant Source_Ptr := Sloc (N);
585 Typ : constant Entity_Id := Etype (N);
586 Btyp : constant Entity_Id := Base_Type (Typ);
587 Rtyp : constant Entity_Id := Root_Type (Typ);
588 Exprs : constant List_Id := Expressions (N);
597 if Rtyp = Standard_Character then
598 Vid := RE_Value_Character;
600 elsif Rtyp = Standard_Boolean then
601 Vid := RE_Value_Boolean;
603 elsif Rtyp = Standard_Wide_Character then
604 Vid := RE_Value_Wide_Character;
607 Make_Integer_Literal (Loc,
608 Intval => Int (Wide_Character_Encoding_Method)));
610 elsif Rtyp = Standard_Wide_Wide_Character then
611 Vid := RE_Value_Wide_Wide_Character;
614 Make_Integer_Literal (Loc,
615 Intval => Int (Wide_Character_Encoding_Method)));
617 elsif Rtyp = Base_Type (Standard_Short_Short_Integer)
618 or else Rtyp = Base_Type (Standard_Short_Integer)
619 or else Rtyp = Base_Type (Standard_Integer)
621 Vid := RE_Value_Integer;
623 elsif Is_Signed_Integer_Type (Rtyp) then
624 Vid := RE_Value_Long_Long_Integer;
626 elsif Is_Modular_Integer_Type (Rtyp) then
627 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
628 Vid := RE_Value_Unsigned;
630 Vid := RE_Value_Long_Long_Unsigned;
633 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
634 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
635 Vid := RE_Value_Decimal;
637 Vid := RE_Value_Long_Long_Decimal;
641 Make_Attribute_Reference (Loc,
642 Prefix => New_Reference_To (Typ, Loc),
643 Attribute_Name => Name_Scale));
647 Make_Function_Call (Loc,
648 Name => New_Reference_To (RTE (Vid), Loc),
649 Parameter_Associations => Args)));
652 Analyze_And_Resolve (N, Btyp);
655 elsif Is_Real_Type (Rtyp) then
656 Vid := RE_Value_Real;
658 -- Only other possibility is user defined enumeration type
661 pragma Assert (Is_Enumeration_Type (Rtyp));
663 -- Case of pragma Discard_Names, transform the Value
664 -- attribute to Btyp'Val (Long_Long_Integer'Value (Args))
666 if Discard_Names (First_Subtype (Typ))
667 or else No (Lit_Strings (Rtyp))
670 Make_Attribute_Reference (Loc,
671 Prefix => New_Reference_To (Btyp, Loc),
672 Attribute_Name => Name_Val,
673 Expressions => New_List (
674 Make_Attribute_Reference (Loc,
676 New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
677 Attribute_Name => Name_Value,
678 Expressions => Args))));
680 Analyze_And_Resolve (N, Btyp);
682 -- Here for normal case where we have enumeration tables, this
685 -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
688 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
690 if Ttyp = Standard_Integer_8 then
691 Func := RE_Value_Enumeration_8;
692 elsif Ttyp = Standard_Integer_16 then
693 Func := RE_Value_Enumeration_16;
695 Func := RE_Value_Enumeration_32;
699 Make_Attribute_Reference (Loc,
700 Prefix => New_Occurrence_Of (Rtyp, Loc),
701 Attribute_Name => Name_Pos,
702 Expressions => New_List (
703 Make_Attribute_Reference (Loc,
704 Prefix => New_Occurrence_Of (Rtyp, Loc),
705 Attribute_Name => Name_Last))));
708 Make_Attribute_Reference (Loc,
709 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
710 Attribute_Name => Name_Address));
713 New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
716 Make_Attribute_Reference (Loc,
717 Prefix => New_Reference_To (Typ, Loc),
718 Attribute_Name => Name_Val,
719 Expressions => New_List (
720 Make_Function_Call (Loc,
722 New_Reference_To (RTE (Func), Loc),
723 Parameter_Associations => Args))));
725 Analyze_And_Resolve (N, Btyp);
731 -- Fall through for all cases except user defined enumeration type
732 -- and decimal types, with Vid set to the Id of the entity for the
733 -- Value routine and Args set to the list of parameters for the call.
735 -- Compiling package Ada.Tags under No_Run_Time_Mode we disable the
736 -- expansion of the attribute into the function call statement to avoid
737 -- generating spurious errors caused by the use of Integer_Address'Value
738 -- in our implementation of Ada.Tags.Internal_Tag
740 -- Seems like a bit of a kludge, there should be a better way ???
742 -- There is a better way, you should also test RTE_Available ???
745 and then Rtyp = RTE (RE_Integer_Address)
746 and then RTU_Loaded (Ada_Tags)
747 and then Cunit_Entity (Current_Sem_Unit)
748 = Body_Entity (RTU_Entity (Ada_Tags))
751 Unchecked_Convert_To (Rtyp,
752 Make_Integer_Literal (Loc, Uint_0)));
756 Make_Function_Call (Loc,
757 Name => New_Reference_To (RTE (Vid), Loc),
758 Parameter_Associations => Args)));
761 Analyze_And_Resolve (N, Btyp);
762 end Expand_Value_Attribute;
764 ---------------------------------
765 -- Expand_Wide_Image_Attribute --
766 ---------------------------------
768 -- We expand typ'Wide_Image (X) as follows. First we insert this code:
770 -- Rnn : Wide_String (1 .. rt'Wide_Width);
772 -- String_To_Wide_String
773 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
775 -- where rt is the root type of the prefix type
777 -- Now we replace the Wide_Image reference by
781 -- This works in all cases because String_To_Wide_String converts any
782 -- wide character escape sequences resulting from the Image call to the
783 -- proper Wide_Character equivalent
785 -- not quite right for typ = Wide_Character ???
787 procedure Expand_Wide_Image_Attribute (N : Node_Id) is
788 Loc : constant Source_Ptr := Sloc (N);
789 Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N)));
790 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
791 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
794 Insert_Actions (N, New_List (
796 -- Rnn : Wide_String (1 .. base_typ'Width);
798 Make_Object_Declaration (Loc,
799 Defining_Identifier => Rnn,
801 Make_Subtype_Indication (Loc,
803 New_Occurrence_Of (Standard_Wide_String, Loc),
805 Make_Index_Or_Discriminant_Constraint (Loc,
806 Constraints => New_List (
808 Low_Bound => Make_Integer_Literal (Loc, 1),
810 Make_Attribute_Reference (Loc,
811 Prefix => New_Occurrence_Of (Rtyp, Loc),
812 Attribute_Name => Name_Wide_Width)))))),
816 Make_Object_Declaration (Loc,
817 Defining_Identifier => Lnn,
818 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
820 -- String_To_Wide_String
821 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
823 Make_Procedure_Call_Statement (Loc,
825 New_Reference_To (RTE (RE_String_To_Wide_String), Loc),
827 Parameter_Associations => New_List (
828 Make_Attribute_Reference (Loc,
829 Prefix => Prefix (N),
830 Attribute_Name => Name_Image,
831 Expressions => Expressions (N)),
832 New_Reference_To (Rnn, Loc),
833 New_Reference_To (Lnn, Loc),
834 Make_Integer_Literal (Loc,
835 Intval => Int (Wide_Character_Encoding_Method))))),
837 -- Suppress checks because we know everything is properly in range
839 Suppress => All_Checks);
841 -- Final step is to rewrite the expression as a slice and analyze,
842 -- again with no checks, since we are sure that everything is OK.
846 Prefix => New_Occurrence_Of (Rnn, Loc),
849 Low_Bound => Make_Integer_Literal (Loc, 1),
850 High_Bound => New_Occurrence_Of (Lnn, Loc))));
852 Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks);
853 end Expand_Wide_Image_Attribute;
855 --------------------------------------
856 -- Expand_Wide_Wide_Image_Attribute --
857 --------------------------------------
859 -- We expand typ'Wide_Wide_Image (X) as follows. First we insert this code:
861 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
863 -- String_To_Wide_Wide_String
864 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
866 -- where rt is the root type of the prefix type
868 -- Now we replace the Wide_Wide_Image reference by
872 -- This works in all cases because String_To_Wide_Wide_String converts any
873 -- wide character escape sequences resulting from the Image call to the
874 -- proper Wide_Wide_Character equivalent
876 -- not quite right for typ = Wide_Wide_Character ???
878 procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is
879 Loc : constant Source_Ptr := Sloc (N);
880 Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N)));
882 Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
883 Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
886 Insert_Actions (N, New_List (
888 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
890 Make_Object_Declaration (Loc,
891 Defining_Identifier => Rnn,
893 Make_Subtype_Indication (Loc,
895 New_Occurrence_Of (Standard_Wide_Wide_String, Loc),
897 Make_Index_Or_Discriminant_Constraint (Loc,
898 Constraints => New_List (
900 Low_Bound => Make_Integer_Literal (Loc, 1),
902 Make_Attribute_Reference (Loc,
903 Prefix => New_Occurrence_Of (Rtyp, Loc),
904 Attribute_Name => Name_Wide_Wide_Width)))))),
908 Make_Object_Declaration (Loc,
909 Defining_Identifier => Lnn,
910 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
912 -- String_To_Wide_Wide_String
913 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
915 Make_Procedure_Call_Statement (Loc,
917 New_Reference_To (RTE (RE_String_To_Wide_Wide_String), Loc),
919 Parameter_Associations => New_List (
920 Make_Attribute_Reference (Loc,
921 Prefix => Prefix (N),
922 Attribute_Name => Name_Image,
923 Expressions => Expressions (N)),
924 New_Reference_To (Rnn, Loc),
925 New_Reference_To (Lnn, Loc),
926 Make_Integer_Literal (Loc,
927 Intval => Int (Wide_Character_Encoding_Method))))),
929 -- Suppress checks because we know everything is properly in range
931 Suppress => All_Checks);
933 -- Final step is to rewrite the expression as a slice and analyze,
934 -- again with no checks, since we are sure that everything is OK.
938 Prefix => New_Occurrence_Of (Rnn, Loc),
941 Low_Bound => Make_Integer_Literal (Loc, 1),
942 High_Bound => New_Occurrence_Of (Lnn, Loc))));
945 (N, Standard_Wide_Wide_String, Suppress => All_Checks);
946 end Expand_Wide_Wide_Image_Attribute;
948 ----------------------------
949 -- Expand_Width_Attribute --
950 ----------------------------
952 -- The processing here also handles the case of Wide_[Wide_]Width. With the
953 -- exceptions noted, the processing is identical
955 -- For scalar types derived from Boolean, character and integer types
956 -- in package Standard. Note that the Width attribute is computed at
957 -- compile time for all cases except those involving non-static sub-
958 -- types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
960 -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
964 -- For types whose root type is Character
965 -- xx = Width_Character
968 -- For types whose root type is Wide_Character
969 -- xx = Wide_Width_Character
972 -- For types whose root type is Wide_Wide_Character
973 -- xx = Wide_Wide_Width_Character
976 -- For types whose root type is Boolean
977 -- xx = Width_Boolean
980 -- For signed integer types
981 -- xx = Width_Long_Long_Integer
982 -- yy = Long_Long_Integer
984 -- For modular integer types
985 -- xx = Width_Long_Long_Unsigned
986 -- yy = Long_Long_Unsigned
988 -- For types derived from Wide_Character, typ'Width expands into
990 -- Result_Type (Width_Wide_Character (
991 -- Wide_Character (typ'First),
992 -- Wide_Character (typ'Last),
994 -- and typ'Wide_Width expands into:
996 -- Result_Type (Wide_Width_Wide_Character (
997 -- Wide_Character (typ'First),
998 -- Wide_Character (typ'Last));
1000 -- and typ'Wide_Wide_Width expands into
1002 -- Result_Type (Wide_Wide_Width_Wide_Character (
1003 -- Wide_Character (typ'First),
1004 -- Wide_Character (typ'Last));
1006 -- For types derived from Wide_Wide_Character, typ'Width expands into
1008 -- Result_Type (Width_Wide_Wide_Character (
1009 -- Wide_Wide_Character (typ'First),
1010 -- Wide_Wide_Character (typ'Last),
1012 -- and typ'Wide_Width expands into:
1014 -- Result_Type (Wide_Width_Wide_Wide_Character (
1015 -- Wide_Wide_Character (typ'First),
1016 -- Wide_Wide_Character (typ'Last));
1018 -- and typ'Wide_Wide_Width expands into
1020 -- Result_Type (Wide_Wide_Width_Wide_Wide_Char (
1021 -- Wide_Wide_Character (typ'First),
1022 -- Wide_Wide_Character (typ'Last));
1024 -- For real types, typ'Width and typ'Wide_[Wide_]Width expand into
1026 -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
1028 -- where btyp is the base type. This looks recursive but it isn't
1029 -- because the base type is always static, and hence the expression
1030 -- in the else is reduced to an integer literal.
1032 -- For user defined enumeration types, typ'Width expands into
1034 -- Result_Type (Width_Enumeration_NN
1037 -- typ'Pos (typ'First),
1038 -- typ'Pos (Typ'Last)));
1040 -- and typ'Wide_Width expands into:
1042 -- Result_Type (Wide_Width_Enumeration_NN
1045 -- typ'Pos (typ'First),
1046 -- typ'Pos (Typ'Last))
1047 -- Wide_Character_Encoding_Method);
1049 -- and typ'Wide_Wide_Width expands into:
1051 -- Result_Type (Wide_Wide_Width_Enumeration_NN
1054 -- typ'Pos (typ'First),
1055 -- typ'Pos (Typ'Last))
1056 -- Wide_Character_Encoding_Method);
1058 -- where typS and typI are the enumeration image strings and
1059 -- indexes table, as described in Build_Enumeration_Image_Tables.
1060 -- NN is 8/16/32 for depending on the element type for typI.
1062 procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is
1063 Loc : constant Source_Ptr := Sloc (N);
1064 Typ : constant Entity_Id := Etype (N);
1065 Pref : constant Node_Id := Prefix (N);
1066 Ptyp : constant Entity_Id := Etype (Pref);
1067 Rtyp : constant Entity_Id := Root_Type (Ptyp);
1074 -- Types derived from Standard.Boolean
1076 if Rtyp = Standard_Boolean then
1077 XX := RE_Width_Boolean;
1080 -- Types derived from Standard.Character
1082 elsif Rtyp = Standard_Character then
1084 when Normal => XX := RE_Width_Character;
1085 when Wide => XX := RE_Wide_Width_Character;
1086 when Wide_Wide => XX := RE_Wide_Wide_Width_Character;
1091 -- Types derived from Standard.Wide_Character
1093 elsif Rtyp = Standard_Wide_Character then
1095 when Normal => XX := RE_Width_Wide_Character;
1096 when Wide => XX := RE_Wide_Width_Wide_Character;
1097 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character;
1102 -- Types derived from Standard.Wide_Wide_Character
1104 elsif Rtyp = Standard_Wide_Wide_Character then
1106 when Normal => XX := RE_Width_Wide_Wide_Character;
1107 when Wide => XX := RE_Wide_Width_Wide_Wide_Character;
1108 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char;
1113 -- Signed integer types
1115 elsif Is_Signed_Integer_Type (Rtyp) then
1116 XX := RE_Width_Long_Long_Integer;
1117 YY := Standard_Long_Long_Integer;
1119 -- Modular integer types
1121 elsif Is_Modular_Integer_Type (Rtyp) then
1122 XX := RE_Width_Long_Long_Unsigned;
1123 YY := RTE (RE_Long_Long_Unsigned);
1127 elsif Is_Real_Type (Rtyp) then
1130 Make_Conditional_Expression (Loc,
1131 Expressions => New_List (
1135 Make_Attribute_Reference (Loc,
1136 Prefix => New_Reference_To (Ptyp, Loc),
1137 Attribute_Name => Name_First),
1140 Make_Attribute_Reference (Loc,
1141 Prefix => New_Reference_To (Ptyp, Loc),
1142 Attribute_Name => Name_Last)),
1144 Make_Integer_Literal (Loc, 0),
1146 Make_Attribute_Reference (Loc,
1147 Prefix => New_Reference_To (Base_Type (Ptyp), Loc),
1148 Attribute_Name => Name_Width))));
1150 Analyze_And_Resolve (N, Typ);
1153 -- User defined enumeration types
1156 pragma Assert (Is_Enumeration_Type (Rtyp));
1158 if Discard_Names (Rtyp) then
1160 -- This is a configurable run-time, or else a restriction is in
1161 -- effect. In either case the attribute cannot be supported. Force
1162 -- a load error from Rtsfind to generate an appropriate message,
1163 -- as is done with other ZFP violations.
1166 Discard : constant Entity_Id := RTE (RE_Null);
1167 pragma Unreferenced (Discard);
1173 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1177 if Ttyp = Standard_Integer_8 then
1178 XX := RE_Width_Enumeration_8;
1179 elsif Ttyp = Standard_Integer_16 then
1180 XX := RE_Width_Enumeration_16;
1182 XX := RE_Width_Enumeration_32;
1186 if Ttyp = Standard_Integer_8 then
1187 XX := RE_Wide_Width_Enumeration_8;
1188 elsif Ttyp = Standard_Integer_16 then
1189 XX := RE_Wide_Width_Enumeration_16;
1191 XX := RE_Wide_Width_Enumeration_32;
1195 if Ttyp = Standard_Integer_8 then
1196 XX := RE_Wide_Wide_Width_Enumeration_8;
1197 elsif Ttyp = Standard_Integer_16 then
1198 XX := RE_Wide_Wide_Width_Enumeration_16;
1200 XX := RE_Wide_Wide_Width_Enumeration_32;
1206 New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
1208 Make_Attribute_Reference (Loc,
1209 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1210 Attribute_Name => Name_Address),
1212 Make_Attribute_Reference (Loc,
1213 Prefix => New_Reference_To (Ptyp, Loc),
1214 Attribute_Name => Name_Pos,
1216 Expressions => New_List (
1217 Make_Attribute_Reference (Loc,
1218 Prefix => New_Reference_To (Ptyp, Loc),
1219 Attribute_Name => Name_First))),
1221 Make_Attribute_Reference (Loc,
1222 Prefix => New_Reference_To (Ptyp, Loc),
1223 Attribute_Name => Name_Pos,
1225 Expressions => New_List (
1226 Make_Attribute_Reference (Loc,
1227 Prefix => New_Reference_To (Ptyp, Loc),
1228 Attribute_Name => Name_Last))));
1232 Make_Function_Call (Loc,
1233 Name => New_Reference_To (RTE (XX), Loc),
1234 Parameter_Associations => Arglist)));
1236 Analyze_And_Resolve (N, Typ);
1240 -- If we fall through XX and YY are set
1242 Arglist := New_List (
1244 Make_Attribute_Reference (Loc,
1245 Prefix => New_Reference_To (Ptyp, Loc),
1246 Attribute_Name => Name_First)),
1249 Make_Attribute_Reference (Loc,
1250 Prefix => New_Reference_To (Ptyp, Loc),
1251 Attribute_Name => Name_Last)));
1255 Make_Function_Call (Loc,
1256 Name => New_Reference_To (RTE (XX), Loc),
1257 Parameter_Associations => Arglist)));
1259 Analyze_And_Resolve (N, Typ);
1260 end Expand_Width_Attribute;
1262 -----------------------
1263 -- Has_Decimal_Small --
1264 -----------------------
1266 function Has_Decimal_Small (E : Entity_Id) return Boolean is
1268 return Is_Decimal_Fixed_Point_Type (E)
1270 (Is_Ordinary_Fixed_Point_Type (E)
1271 and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1);
1272 end Has_Decimal_Small;