1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2007, 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_Res; use Sem_Res;
38 with Sinfo; use Sinfo;
39 with Snames; use Snames;
40 with Stand; use Stand;
41 with Stringt; use Stringt;
42 with Tbuild; use Tbuild;
43 with Ttypes; use Ttypes;
44 with Uintp; use Uintp;
46 package body Exp_Imgv is
48 ------------------------------------
49 -- Build_Enumeration_Image_Tables --
50 ------------------------------------
52 procedure Build_Enumeration_Image_Tables (E : Entity_Id; N : Node_Id) is
53 Loc : constant Source_Ptr := Sloc (E);
64 -- Nothing to do for other than a root enumeration type
66 if E /= Root_Type (E) then
69 -- Nothing to do if pragma Discard_Names applies
71 elsif Discard_Names (E) then
75 -- Otherwise tables need constructing
79 Lit := First_Literal (E);
85 Make_Integer_Literal (Loc, UI_From_Int (Len)));
90 Get_Unqualified_Decoded_Name_String (Chars (Lit));
92 if Name_Buffer (1) /= ''' then
93 Set_Casing (All_Upper_Case);
96 Store_String_Chars (Name_Buffer (1 .. Name_Len));
97 Len := Len + Int (Name_Len);
101 if Len < Int (2 ** (8 - 1)) then
102 Ityp := Standard_Integer_8;
103 elsif Len < Int (2 ** (16 - 1)) then
104 Ityp := Standard_Integer_16;
106 Ityp := Standard_Integer_32;
112 Make_Defining_Identifier (Loc,
113 Chars => New_External_Name (Chars (E), 'S'));
116 Make_Defining_Identifier (Loc,
117 Chars => New_External_Name (Chars (E), 'N'));
119 Set_Lit_Strings (E, Estr);
120 Set_Lit_Indexes (E, Eind);
124 Make_Object_Declaration (Loc,
125 Defining_Identifier => Estr,
126 Constant_Present => True,
128 New_Occurrence_Of (Standard_String, Loc),
130 Make_String_Literal (Loc,
133 Make_Object_Declaration (Loc,
134 Defining_Identifier => Eind,
135 Constant_Present => True,
138 Make_Constrained_Array_Definition (Loc,
139 Discrete_Subtype_Definitions => New_List (
141 Low_Bound => Make_Integer_Literal (Loc, 0),
142 High_Bound => Make_Integer_Literal (Loc, Nlit))),
143 Component_Definition =>
144 Make_Component_Definition (Loc,
145 Aliased_Present => False,
146 Subtype_Indication => New_Occurrence_Of (Ityp, Loc))),
150 Expressions => Ind))),
151 Suppress => All_Checks);
152 end Build_Enumeration_Image_Tables;
154 ----------------------------
155 -- Expand_Image_Attribute --
156 ----------------------------
158 -- For all cases other than user defined enumeration types, the scheme
159 -- is as follows. First we insert the following code:
161 -- Snn : String (1 .. rt'Width);
163 -- Image_xx (tv, Snn, Pnn [,pm]);
165 -- and then Expr is replaced by Snn (1 .. Pnn)
167 -- In the above expansion:
169 -- rt is the root type of the expression
170 -- tv is the expression with the value, usually a type conversion
171 -- pm is an extra parameter present in some cases
173 -- The following table shows tv, xx, and (if used) pm for the various
174 -- possible types of the argument:
176 -- For types whose root type is Character
178 -- tv = Character (Expr)
180 -- For types whose root type is Boolean
182 -- tv = Boolean (Expr)
184 -- For signed integer types with size <= Integer'Size
186 -- tv = Integer (Expr)
188 -- For other signed integer types
189 -- xx = Long_Long_Integer
190 -- tv = Long_Long_Integer (Expr)
192 -- For modular types with modulus <= System.Unsigned_Types.Unsigned
194 -- tv = System.Unsigned_Types.Unsigned (Expr)
196 -- For other modular integer types
197 -- xx = Long_Long_Unsigned
198 -- tv = System.Unsigned_Types.Long_Long_Unsigned (Expr)
200 -- For types whose root type is Wide_Character
201 -- xx = Wide_Character
202 -- tv = Wide_Character (Expr)
203 -- pm = Boolean, true if Ada 2005 mode, False otherwise
205 -- For types whose root type is Wide_Wide_Character
206 -- xx = Wide_Wide_Character
207 -- tv = Wide_Wide_Character (Expr)
209 -- For floating-point types
210 -- xx = Floating_Point
211 -- tv = Long_Long_Float (Expr)
212 -- pm = typ'Digits (typ = subtype of expression)
214 -- For ordinary fixed-point types
215 -- xx = Ordinary_Fixed_Point
216 -- tv = Long_Long_Float (Expr)
217 -- pm = typ'Aft (typ = subtype of expression)
219 -- For decimal fixed-point types with size = Integer'Size
221 -- tv = Integer (Expr)
222 -- pm = typ'Scale (typ = subtype of expression)
224 -- For decimal fixed-point types with size > Integer'Size
225 -- xx = Long_Long_Decimal
226 -- tv = Long_Long_Integer?(Expr) [convert with no scaling]
227 -- pm = typ'Scale (typ = subtype of expression)
229 -- For enumeration types other than those declared packages Standard
230 -- or System, Snn, Pnn, are expanded as above, but the call looks like:
232 -- Image_Enumeration_NN (rt'Pos (X), Snn, Pnn, typS, typI'Address)
234 -- where rt is the root type of the expression, and typS and typI are
235 -- the entities constructed as described in the spec for the procedure
236 -- Build_Enumeration_Image_Tables and NN is 32/16/8 depending on the
237 -- element type of Lit_Indexes. The rewriting of the expression to
238 -- Snn (1 .. Pnn) then occurs as in the other cases. A special case is
239 -- when pragma Discard_Names applies, in which case we replace expr by:
243 procedure Expand_Image_Attribute (N : Node_Id) is
244 Loc : constant Source_Ptr := Sloc (N);
245 Exprs : constant List_Id := Expressions (N);
246 Pref : constant Node_Id := Prefix (N);
247 Ptyp : constant Entity_Id := Entity (Pref);
248 Rtyp : constant Entity_Id := Root_Type (Ptyp);
249 Expr : constant Node_Id := Relocate_Node (First (Exprs));
253 Proc_Ent : Entity_Id;
257 -- List of arguments for run-time procedure call
260 -- List of actions to be inserted
262 Snn : constant Entity_Id :=
263 Make_Defining_Identifier (Loc,
264 Chars => New_Internal_Name ('S'));
266 Pnn : constant Entity_Id :=
267 Make_Defining_Identifier (Loc,
268 Chars => New_Internal_Name ('P'));
271 -- Build declarations of Snn and Pnn to be inserted
273 Ins_List := New_List (
275 -- Snn : String (1 .. typ'Width);
277 Make_Object_Declaration (Loc,
278 Defining_Identifier => Snn,
280 Make_Subtype_Indication (Loc,
281 Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
283 Make_Index_Or_Discriminant_Constraint (Loc,
284 Constraints => New_List (
286 Low_Bound => Make_Integer_Literal (Loc, 1),
288 Make_Attribute_Reference (Loc,
289 Prefix => New_Occurrence_Of (Rtyp, Loc),
290 Attribute_Name => Name_Width)))))),
294 Make_Object_Declaration (Loc,
295 Defining_Identifier => Pnn,
296 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)));
298 -- Set Imid (RE_Id of procedure to call), and Tent, target for the
299 -- type conversion of the first argument for all possibilities.
303 if Rtyp = Standard_Boolean then
304 Imid := RE_Image_Boolean;
307 elsif Rtyp = Standard_Character then
308 Imid := RE_Image_Character;
311 elsif Rtyp = Standard_Wide_Character then
312 Imid := RE_Image_Wide_Character;
315 elsif Rtyp = Standard_Wide_Wide_Character then
316 Imid := RE_Image_Wide_Wide_Character;
319 elsif Is_Signed_Integer_Type (Rtyp) then
320 if Esize (Rtyp) <= Esize (Standard_Integer) then
321 Imid := RE_Image_Integer;
322 Tent := Standard_Integer;
324 Imid := RE_Image_Long_Long_Integer;
325 Tent := Standard_Long_Long_Integer;
328 elsif Is_Modular_Integer_Type (Rtyp) then
329 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
330 Imid := RE_Image_Unsigned;
331 Tent := RTE (RE_Unsigned);
333 Imid := RE_Image_Long_Long_Unsigned;
334 Tent := RTE (RE_Long_Long_Unsigned);
337 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
338 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
339 Imid := RE_Image_Decimal;
340 Tent := Standard_Integer;
342 Imid := RE_Image_Long_Long_Decimal;
343 Tent := Standard_Long_Long_Integer;
346 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
347 Imid := RE_Image_Ordinary_Fixed_Point;
348 Tent := Standard_Long_Long_Float;
350 elsif Is_Floating_Point_Type (Rtyp) then
351 Imid := RE_Image_Floating_Point;
352 Tent := Standard_Long_Long_Float;
354 -- Only other possibility is user defined enumeration type
357 if Discard_Names (First_Subtype (Ptyp))
358 or else No (Lit_Strings (Root_Type (Ptyp)))
360 -- When pragma Discard_Names applies to the first subtype,
361 -- then build (Pref'Pos)'Img.
364 Make_Attribute_Reference (Loc,
366 Make_Attribute_Reference (Loc,
368 Attribute_Name => Name_Pos,
369 Expressions => New_List (Expr)),
372 Analyze_And_Resolve (N, Standard_String);
376 -- Here for enumeration type case
378 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
380 if Ttyp = Standard_Integer_8 then
381 Imid := RE_Image_Enumeration_8;
382 elsif Ttyp = Standard_Integer_16 then
383 Imid := RE_Image_Enumeration_16;
385 Imid := RE_Image_Enumeration_32;
388 -- Apply a validity check, since it is a bit drastic to get a
389 -- completely junk image value for an invalid value.
391 if not Expr_Known_Valid (Expr) then
392 Insert_Valid_Check (Expr);
399 -- Build first argument for call
402 Arg_List := New_List (
403 Make_Attribute_Reference (Loc,
404 Attribute_Name => Name_Pos,
405 Prefix => New_Occurrence_Of (Ptyp, Loc),
406 Expressions => New_List (Expr)));
409 Arg_List := New_List (Convert_To (Tent, Expr));
412 -- Append Snn, Pnn arguments
414 Append_To (Arg_List, New_Occurrence_Of (Snn, Loc));
415 Append_To (Arg_List, New_Occurrence_Of (Pnn, Loc));
417 -- Get entity of procedure to call
419 Proc_Ent := RTE (Imid);
421 -- If the procedure entity is empty, that means we have a case in
422 -- no run time mode where the operation is not allowed, and an
423 -- appropriate diagnostic has already been issued.
425 if No (Proc_Ent) then
429 -- Otherwise complete preparation of arguments for run-time call
431 -- Add extra arguments for Enumeration case
434 Append_To (Arg_List, New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
436 Make_Attribute_Reference (Loc,
437 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
438 Attribute_Name => Name_Address));
440 -- For floating-point types, append Digits argument
442 elsif Is_Floating_Point_Type (Rtyp) then
444 Make_Attribute_Reference (Loc,
445 Prefix => New_Reference_To (Ptyp, Loc),
446 Attribute_Name => Name_Digits));
448 -- For ordinary fixed-point types, append Aft parameter
450 elsif Is_Ordinary_Fixed_Point_Type (Rtyp) then
452 Make_Attribute_Reference (Loc,
453 Prefix => New_Reference_To (Ptyp, Loc),
454 Attribute_Name => Name_Aft));
456 -- For decimal, append Scale and also set to do literal conversion
458 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
460 Make_Attribute_Reference (Loc,
461 Prefix => New_Reference_To (Ptyp, Loc),
462 Attribute_Name => Name_Scale));
464 Set_Conversion_OK (First (Arg_List));
465 Set_Etype (First (Arg_List), Tent);
467 -- For Wide_Character, append Ada 2005 indication
469 elsif Rtyp = Standard_Wide_Character then
471 New_Reference_To (Boolean_Literals (Ada_Version >= Ada_05), Loc));
474 -- Now append the procedure call to the insert list
477 Make_Procedure_Call_Statement (Loc,
478 Name => New_Reference_To (Proc_Ent, Loc),
479 Parameter_Associations => Arg_List));
481 -- Insert declarations of Snn, Pnn, and the procedure call. We suppress
482 -- checks because we are sure that everything is in range at this stage.
484 Insert_Actions (N, Ins_List, Suppress => All_Checks);
486 -- Final step is to rewrite the expression as a slice and analyze,
487 -- again with no checks, since we are sure that everything is OK.
491 Prefix => New_Occurrence_Of (Snn, Loc),
494 Low_Bound => Make_Integer_Literal (Loc, 1),
495 High_Bound => New_Occurrence_Of (Pnn, Loc))));
497 Analyze_And_Resolve (N, Standard_String, Suppress => All_Checks);
498 end Expand_Image_Attribute;
500 ----------------------------
501 -- Expand_Value_Attribute --
502 ----------------------------
504 -- For scalar types derived from Boolean, Character and integer types
505 -- in package Standard, typ'Value (X) expands into:
507 -- btyp (Value_xx (X))
509 -- where btyp is he base type of the prefix
511 -- For types whose root type is Character
514 -- For types whose root type is Wide_Character
515 -- xx = Wide_Character
517 -- For types whose root type is Wide_Wide_Character
518 -- xx = Wide_Wide_Character
520 -- For types whose root type is Boolean
523 -- For signed integer types with size <= Integer'Size
526 -- For other signed integer types
527 -- xx = Long_Long_Integer
529 -- For modular types with modulus <= System.Unsigned_Types.Unsigned
532 -- For other modular integer types
533 -- xx = Long_Long_Unsigned
535 -- For floating-point types and ordinary fixed-point types
538 -- For Wide_[Wide_]Character types, typ'Value (X) expands into:
540 -- btyp (Value_xx (X, EM))
542 -- where btyp is the base type of the prefix, and EM is the encoding method
544 -- For decimal types with size <= Integer'Size, typ'Value (X)
547 -- btyp?(Value_Decimal (X, typ'Scale));
549 -- For all other decimal types, typ'Value (X) expands into
551 -- btyp?(Value_Long_Long_Decimal (X, typ'Scale))
553 -- For enumeration types other than those derived from types Boolean,
554 -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
556 -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
558 -- where typS and typI and the Lit_Strings and Lit_Indexes entities
559 -- from T's root type entity, and Num is Enum'Pos (Enum'Last). The
560 -- Value_Enumeration_NN function will search the tables looking for
561 -- X and return the position number in the table if found which is
562 -- used to provide the result of 'Value (using Enum'Val). If the
563 -- value is not found Constraint_Error is raised. The suffix _NN
564 -- depends on the element type of typI.
566 procedure Expand_Value_Attribute (N : Node_Id) is
567 Loc : constant Source_Ptr := Sloc (N);
568 Typ : constant Entity_Id := Etype (N);
569 Btyp : constant Entity_Id := Base_Type (Typ);
570 Rtyp : constant Entity_Id := Root_Type (Typ);
571 Exprs : constant List_Id := Expressions (N);
580 if Rtyp = Standard_Character then
581 Vid := RE_Value_Character;
583 elsif Rtyp = Standard_Boolean then
584 Vid := RE_Value_Boolean;
586 elsif Rtyp = Standard_Wide_Character then
587 Vid := RE_Value_Wide_Character;
590 Make_Integer_Literal (Loc,
591 Intval => Int (Wide_Character_Encoding_Method)));
593 elsif Rtyp = Standard_Wide_Wide_Character then
594 Vid := RE_Value_Wide_Wide_Character;
597 Make_Integer_Literal (Loc,
598 Intval => Int (Wide_Character_Encoding_Method)));
600 elsif Rtyp = Base_Type (Standard_Short_Short_Integer)
601 or else Rtyp = Base_Type (Standard_Short_Integer)
602 or else Rtyp = Base_Type (Standard_Integer)
604 Vid := RE_Value_Integer;
606 elsif Is_Signed_Integer_Type (Rtyp) then
607 Vid := RE_Value_Long_Long_Integer;
609 elsif Is_Modular_Integer_Type (Rtyp) then
610 if Modulus (Rtyp) <= Modulus (RTE (RE_Unsigned)) then
611 Vid := RE_Value_Unsigned;
613 Vid := RE_Value_Long_Long_Unsigned;
616 elsif Is_Decimal_Fixed_Point_Type (Rtyp) then
617 if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
618 Vid := RE_Value_Decimal;
620 Vid := RE_Value_Long_Long_Decimal;
624 Make_Attribute_Reference (Loc,
625 Prefix => New_Reference_To (Typ, Loc),
626 Attribute_Name => Name_Scale));
630 Make_Function_Call (Loc,
631 Name => New_Reference_To (RTE (Vid), Loc),
632 Parameter_Associations => Args)));
635 Analyze_And_Resolve (N, Btyp);
638 elsif Is_Real_Type (Rtyp) then
639 Vid := RE_Value_Real;
641 -- Only other possibility is user defined enumeration type
644 pragma Assert (Is_Enumeration_Type (Rtyp));
646 -- Case of pragma Discard_Names, transform the Value
647 -- attribute to Btyp'Val (Long_Long_Integer'Value (Args))
649 if Discard_Names (First_Subtype (Typ))
650 or else No (Lit_Strings (Rtyp))
653 Make_Attribute_Reference (Loc,
654 Prefix => New_Reference_To (Btyp, Loc),
655 Attribute_Name => Name_Val,
656 Expressions => New_List (
657 Make_Attribute_Reference (Loc,
659 New_Occurrence_Of (Standard_Long_Long_Integer, Loc),
660 Attribute_Name => Name_Value,
661 Expressions => Args))));
663 Analyze_And_Resolve (N, Btyp);
665 -- Here for normal case where we have enumeration tables, this
668 -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
671 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
673 if Ttyp = Standard_Integer_8 then
674 Func := RE_Value_Enumeration_8;
675 elsif Ttyp = Standard_Integer_16 then
676 Func := RE_Value_Enumeration_16;
678 Func := RE_Value_Enumeration_32;
682 Make_Attribute_Reference (Loc,
683 Prefix => New_Occurrence_Of (Rtyp, Loc),
684 Attribute_Name => Name_Pos,
685 Expressions => New_List (
686 Make_Attribute_Reference (Loc,
687 Prefix => New_Occurrence_Of (Rtyp, Loc),
688 Attribute_Name => Name_Last))));
691 Make_Attribute_Reference (Loc,
692 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
693 Attribute_Name => Name_Address));
696 New_Occurrence_Of (Lit_Strings (Rtyp), Loc));
699 Make_Attribute_Reference (Loc,
700 Prefix => New_Reference_To (Typ, Loc),
701 Attribute_Name => Name_Val,
702 Expressions => New_List (
703 Make_Function_Call (Loc,
705 New_Reference_To (RTE (Func), Loc),
706 Parameter_Associations => Args))));
708 Analyze_And_Resolve (N, Btyp);
714 -- Fall through for all cases except user defined enumeration type
715 -- and decimal types, with Vid set to the Id of the entity for the
716 -- Value routine and Args set to the list of parameters for the call.
718 -- Compiling package Ada.Tags under No_Run_Time_Mode we disable the
719 -- expansion of the attribute into the function call statement to avoid
720 -- generating spurious errors caused by the use of Integer_Address'Value
721 -- in our implementation of Ada.Tags.Internal_Tag
723 -- Seems like a bit of a kludge, there should be a better way ???
725 -- There is a better way, you should also test RTE_Available ???
728 and then Rtyp = RTE (RE_Integer_Address)
729 and then RTU_Loaded (Ada_Tags)
730 and then Cunit_Entity (Current_Sem_Unit)
731 = Body_Entity (RTU_Entity (Ada_Tags))
734 Unchecked_Convert_To (Rtyp,
735 Make_Integer_Literal (Loc, Uint_0)));
739 Make_Function_Call (Loc,
740 Name => New_Reference_To (RTE (Vid), Loc),
741 Parameter_Associations => Args)));
744 Analyze_And_Resolve (N, Btyp);
745 end Expand_Value_Attribute;
747 ---------------------------------
748 -- Expand_Wide_Image_Attribute --
749 ---------------------------------
751 -- We expand typ'Wide_Image (X) as follows. First we insert this code:
753 -- Rnn : Wide_String (1 .. rt'Wide_Width);
755 -- String_To_Wide_String
756 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
758 -- where rt is the root type of the prefix type
760 -- Now we replace the Wide_Image reference by
764 -- This works in all cases because String_To_Wide_String converts any
765 -- wide character escape sequences resulting from the Image call to the
766 -- proper Wide_Character equivalent
768 -- not quite right for typ = Wide_Character ???
770 procedure Expand_Wide_Image_Attribute (N : Node_Id) is
771 Loc : constant Source_Ptr := Sloc (N);
772 Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N)));
774 Rnn : constant Entity_Id :=
775 Make_Defining_Identifier (Loc,
776 Chars => New_Internal_Name ('S'));
778 Lnn : constant Entity_Id :=
779 Make_Defining_Identifier (Loc,
780 Chars => New_Internal_Name ('P'));
783 Insert_Actions (N, New_List (
785 -- Rnn : Wide_String (1 .. base_typ'Width);
787 Make_Object_Declaration (Loc,
788 Defining_Identifier => Rnn,
790 Make_Subtype_Indication (Loc,
792 New_Occurrence_Of (Standard_Wide_String, Loc),
794 Make_Index_Or_Discriminant_Constraint (Loc,
795 Constraints => New_List (
797 Low_Bound => Make_Integer_Literal (Loc, 1),
799 Make_Attribute_Reference (Loc,
800 Prefix => New_Occurrence_Of (Rtyp, Loc),
801 Attribute_Name => Name_Wide_Width)))))),
805 Make_Object_Declaration (Loc,
806 Defining_Identifier => Lnn,
807 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
809 -- String_To_Wide_String
810 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
812 Make_Procedure_Call_Statement (Loc,
814 New_Reference_To (RTE (RE_String_To_Wide_String), Loc),
816 Parameter_Associations => New_List (
817 Make_Attribute_Reference (Loc,
818 Prefix => Prefix (N),
819 Attribute_Name => Name_Image,
820 Expressions => Expressions (N)),
821 New_Reference_To (Rnn, Loc),
822 New_Reference_To (Lnn, Loc),
823 Make_Integer_Literal (Loc,
824 Intval => Int (Wide_Character_Encoding_Method))))),
826 -- Suppress checks because we know everything is properly in range
828 Suppress => All_Checks);
830 -- Final step is to rewrite the expression as a slice and analyze,
831 -- again with no checks, since we are sure that everything is OK.
835 Prefix => New_Occurrence_Of (Rnn, Loc),
838 Low_Bound => Make_Integer_Literal (Loc, 1),
839 High_Bound => New_Occurrence_Of (Lnn, Loc))));
841 Analyze_And_Resolve (N, Standard_Wide_String, Suppress => All_Checks);
842 end Expand_Wide_Image_Attribute;
844 --------------------------------------
845 -- Expand_Wide_Wide_Image_Attribute --
846 --------------------------------------
848 -- We expand typ'Wide_Wide_Image (X) as follows. First we insert this code:
850 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
852 -- String_To_Wide_Wide_String
853 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
855 -- where rt is the root type of the prefix type
857 -- Now we replace the Wide_Wide_Image reference by
861 -- This works in all cases because String_To_Wide_Wide_String converts any
862 -- wide character escape sequences resulting from the Image call to the
863 -- proper Wide_Wide_Character equivalent
865 -- not quite right for typ = Wide_Wide_Character ???
867 procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is
868 Loc : constant Source_Ptr := Sloc (N);
869 Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N)));
871 Rnn : constant Entity_Id :=
872 Make_Defining_Identifier (Loc,
873 Chars => New_Internal_Name ('S'));
875 Lnn : constant Entity_Id :=
876 Make_Defining_Identifier (Loc,
877 Chars => New_Internal_Name ('P'));
880 Insert_Actions (N, New_List (
882 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
884 Make_Object_Declaration (Loc,
885 Defining_Identifier => Rnn,
887 Make_Subtype_Indication (Loc,
889 New_Occurrence_Of (Standard_Wide_Wide_String, Loc),
891 Make_Index_Or_Discriminant_Constraint (Loc,
892 Constraints => New_List (
894 Low_Bound => Make_Integer_Literal (Loc, 1),
896 Make_Attribute_Reference (Loc,
897 Prefix => New_Occurrence_Of (Rtyp, Loc),
898 Attribute_Name => Name_Wide_Wide_Width)))))),
902 Make_Object_Declaration (Loc,
903 Defining_Identifier => Lnn,
904 Object_Definition => New_Occurrence_Of (Standard_Natural, Loc)),
906 -- String_To_Wide_Wide_String
907 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
909 Make_Procedure_Call_Statement (Loc,
911 New_Reference_To (RTE (RE_String_To_Wide_Wide_String), Loc),
913 Parameter_Associations => New_List (
914 Make_Attribute_Reference (Loc,
915 Prefix => Prefix (N),
916 Attribute_Name => Name_Image,
917 Expressions => Expressions (N)),
918 New_Reference_To (Rnn, Loc),
919 New_Reference_To (Lnn, Loc),
920 Make_Integer_Literal (Loc,
921 Intval => Int (Wide_Character_Encoding_Method))))),
923 -- Suppress checks because we know everything is properly in range
925 Suppress => All_Checks);
927 -- Final step is to rewrite the expression as a slice and analyze,
928 -- again with no checks, since we are sure that everything is OK.
932 Prefix => New_Occurrence_Of (Rnn, Loc),
935 Low_Bound => Make_Integer_Literal (Loc, 1),
936 High_Bound => New_Occurrence_Of (Lnn, Loc))));
939 (N, Standard_Wide_Wide_String, Suppress => All_Checks);
940 end Expand_Wide_Wide_Image_Attribute;
942 ----------------------------
943 -- Expand_Width_Attribute --
944 ----------------------------
946 -- The processing here also handles the case of Wide_[Wide_]Width. With the
947 -- exceptions noted, the processing is identical
949 -- For scalar types derived from Boolean, character and integer types
950 -- in package Standard. Note that the Width attribute is computed at
951 -- compile time for all cases except those involving non-static sub-
952 -- types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
954 -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
958 -- For types whose root type is Character
959 -- xx = Width_Character
962 -- For types whose root type is Wide_Character
963 -- xx = Wide_Width_Character
966 -- For types whose root type is Wide_Wide_Character
967 -- xx = Wide_Wide_Width_Character
970 -- For types whose root type is Boolean
971 -- xx = Width_Boolean
974 -- For signed integer types
975 -- xx = Width_Long_Long_Integer
976 -- yy = Long_Long_Integer
978 -- For modular integer types
979 -- xx = Width_Long_Long_Unsigned
980 -- yy = Long_Long_Unsigned
982 -- For types derived from Wide_Character, typ'Width expands into
984 -- Result_Type (Width_Wide_Character (
985 -- Wide_Character (typ'First),
986 -- Wide_Character (typ'Last),
988 -- and typ'Wide_Width expands into:
990 -- Result_Type (Wide_Width_Wide_Character (
991 -- Wide_Character (typ'First),
992 -- Wide_Character (typ'Last));
994 -- and typ'Wide_Wide_Width expands into
996 -- Result_Type (Wide_Wide_Width_Wide_Character (
997 -- Wide_Character (typ'First),
998 -- Wide_Character (typ'Last));
1000 -- For types derived from Wide_Wide_Character, typ'Width expands into
1002 -- Result_Type (Width_Wide_Wide_Character (
1003 -- Wide_Wide_Character (typ'First),
1004 -- Wide_Wide_Character (typ'Last),
1006 -- and typ'Wide_Width expands into:
1008 -- Result_Type (Wide_Width_Wide_Wide_Character (
1009 -- Wide_Wide_Character (typ'First),
1010 -- Wide_Wide_Character (typ'Last));
1012 -- and typ'Wide_Wide_Width expands into
1014 -- Result_Type (Wide_Wide_Width_Wide_Wide_Char (
1015 -- Wide_Wide_Character (typ'First),
1016 -- Wide_Wide_Character (typ'Last));
1018 -- For real types, typ'Width and typ'Wide_[Wide_]Width expand into
1020 -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
1022 -- where btyp is the base type. This looks recursive but it isn't
1023 -- because the base type is always static, and hence the expression
1024 -- in the else is reduced to an integer literal.
1026 -- For user defined enumeration types, typ'Width expands into
1028 -- Result_Type (Width_Enumeration_NN
1031 -- typ'Pos (typ'First),
1032 -- typ'Pos (Typ'Last)));
1034 -- and typ'Wide_Width expands into:
1036 -- Result_Type (Wide_Width_Enumeration_NN
1039 -- typ'Pos (typ'First),
1040 -- typ'Pos (Typ'Last))
1041 -- Wide_Character_Encoding_Method);
1043 -- and typ'Wide_Wide_Width expands into:
1045 -- Result_Type (Wide_Wide_Width_Enumeration_NN
1048 -- typ'Pos (typ'First),
1049 -- typ'Pos (Typ'Last))
1050 -- Wide_Character_Encoding_Method);
1052 -- where typS and typI are the enumeration image strings and
1053 -- indexes table, as described in Build_Enumeration_Image_Tables.
1054 -- NN is 8/16/32 for depending on the element type for typI.
1056 procedure Expand_Width_Attribute (N : Node_Id; Attr : Atype := Normal) is
1057 Loc : constant Source_Ptr := Sloc (N);
1058 Typ : constant Entity_Id := Etype (N);
1059 Pref : constant Node_Id := Prefix (N);
1060 Ptyp : constant Entity_Id := Etype (Pref);
1061 Rtyp : constant Entity_Id := Root_Type (Ptyp);
1068 -- Types derived from Standard.Boolean
1070 if Rtyp = Standard_Boolean then
1071 XX := RE_Width_Boolean;
1074 -- Types derived from Standard.Character
1076 elsif Rtyp = Standard_Character then
1078 when Normal => XX := RE_Width_Character;
1079 when Wide => XX := RE_Wide_Width_Character;
1080 when Wide_Wide => XX := RE_Wide_Wide_Width_Character;
1085 -- Types derived from Standard.Wide_Character
1087 elsif Rtyp = Standard_Wide_Character then
1089 when Normal => XX := RE_Width_Wide_Character;
1090 when Wide => XX := RE_Wide_Width_Wide_Character;
1091 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Character;
1096 -- Types derived from Standard.Wide_Wide_Character
1098 elsif Rtyp = Standard_Wide_Wide_Character then
1100 when Normal => XX := RE_Width_Wide_Wide_Character;
1101 when Wide => XX := RE_Wide_Width_Wide_Wide_Character;
1102 when Wide_Wide => XX := RE_Wide_Wide_Width_Wide_Wide_Char;
1107 -- Signed integer types
1109 elsif Is_Signed_Integer_Type (Rtyp) then
1110 XX := RE_Width_Long_Long_Integer;
1111 YY := Standard_Long_Long_Integer;
1113 -- Modular integer types
1115 elsif Is_Modular_Integer_Type (Rtyp) then
1116 XX := RE_Width_Long_Long_Unsigned;
1117 YY := RTE (RE_Long_Long_Unsigned);
1121 elsif Is_Real_Type (Rtyp) then
1124 Make_Conditional_Expression (Loc,
1125 Expressions => New_List (
1129 Make_Attribute_Reference (Loc,
1130 Prefix => New_Reference_To (Ptyp, Loc),
1131 Attribute_Name => Name_First),
1134 Make_Attribute_Reference (Loc,
1135 Prefix => New_Reference_To (Ptyp, Loc),
1136 Attribute_Name => Name_Last)),
1138 Make_Integer_Literal (Loc, 0),
1140 Make_Attribute_Reference (Loc,
1141 Prefix => New_Reference_To (Base_Type (Ptyp), Loc),
1142 Attribute_Name => Name_Width))));
1144 Analyze_And_Resolve (N, Typ);
1147 -- User defined enumeration types
1150 pragma Assert (Is_Enumeration_Type (Rtyp));
1152 if Discard_Names (Rtyp) then
1154 -- This is a configurable run-time, or else a restriction is in
1155 -- effect. In either case the attribute cannot be supported. Force
1156 -- a load error from Rtsfind to generate an appropriate message,
1157 -- as is done with other ZFP violations.
1160 pragma Warnings (Off); -- since Discard is unreferenced
1161 Discard : constant Entity_Id := RTE (RE_Null);
1162 pragma Warnings (On);
1168 Ttyp := Component_Type (Etype (Lit_Indexes (Rtyp)));
1172 if Ttyp = Standard_Integer_8 then
1173 XX := RE_Width_Enumeration_8;
1174 elsif Ttyp = Standard_Integer_16 then
1175 XX := RE_Width_Enumeration_16;
1177 XX := RE_Width_Enumeration_32;
1181 if Ttyp = Standard_Integer_8 then
1182 XX := RE_Wide_Width_Enumeration_8;
1183 elsif Ttyp = Standard_Integer_16 then
1184 XX := RE_Wide_Width_Enumeration_16;
1186 XX := RE_Wide_Width_Enumeration_32;
1190 if Ttyp = Standard_Integer_8 then
1191 XX := RE_Wide_Wide_Width_Enumeration_8;
1192 elsif Ttyp = Standard_Integer_16 then
1193 XX := RE_Wide_Wide_Width_Enumeration_16;
1195 XX := RE_Wide_Wide_Width_Enumeration_32;
1201 New_Occurrence_Of (Lit_Strings (Rtyp), Loc),
1203 Make_Attribute_Reference (Loc,
1204 Prefix => New_Occurrence_Of (Lit_Indexes (Rtyp), Loc),
1205 Attribute_Name => Name_Address),
1207 Make_Attribute_Reference (Loc,
1208 Prefix => New_Reference_To (Ptyp, Loc),
1209 Attribute_Name => Name_Pos,
1211 Expressions => New_List (
1212 Make_Attribute_Reference (Loc,
1213 Prefix => New_Reference_To (Ptyp, Loc),
1214 Attribute_Name => Name_First))),
1216 Make_Attribute_Reference (Loc,
1217 Prefix => New_Reference_To (Ptyp, Loc),
1218 Attribute_Name => Name_Pos,
1220 Expressions => New_List (
1221 Make_Attribute_Reference (Loc,
1222 Prefix => New_Reference_To (Ptyp, Loc),
1223 Attribute_Name => Name_Last))));
1227 Make_Function_Call (Loc,
1228 Name => New_Reference_To (RTE (XX), Loc),
1229 Parameter_Associations => Arglist)));
1231 Analyze_And_Resolve (N, Typ);
1235 -- If we fall through XX and YY are set
1237 Arglist := New_List (
1239 Make_Attribute_Reference (Loc,
1240 Prefix => New_Reference_To (Ptyp, Loc),
1241 Attribute_Name => Name_First)),
1244 Make_Attribute_Reference (Loc,
1245 Prefix => New_Reference_To (Ptyp, Loc),
1246 Attribute_Name => Name_Last)));
1250 Make_Function_Call (Loc,
1251 Name => New_Reference_To (RTE (XX), Loc),
1252 Parameter_Associations => Arglist)));
1254 Analyze_And_Resolve (N, Typ);
1255 end Expand_Width_Attribute;