1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2005, 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Casing
; use Casing
;
29 with Checks
; use Checks
;
30 with Einfo
; use Einfo
;
31 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 non-enumeration types, and for enumeration types declared
159 -- in packages Standard or System, typ'Image (Val) expands into:
161 -- Image_xx (tp (Expr) [, pm])
163 -- The name xx and type conversion tp (Expr) (called tv below) depend on
164 -- the root type of Expr. The argument pm is an extra type dependent
165 -- parameter only used in some cases as follows:
167 -- For types whose root type is Character
169 -- tv = Character (Expr)
171 -- For types whose root type is Boolean
173 -- tv = Boolean (Expr)
175 -- For signed integer types with size <= Integer'Size
177 -- tv = Integer (Expr)
179 -- For other signed integer types
180 -- xx = Long_Long_Integer
181 -- tv = Long_Long_Integer (Expr)
183 -- For modular types with modulus <= System.Unsigned_Types.Unsigned
185 -- tv = System.Unsigned_Types.Unsigned (Expr)
187 -- For other modular integer types
188 -- xx = Long_Long_Unsigned
189 -- tv = System.Unsigned_Types.Long_Long_Unsigned (Expr)
191 -- For types whose root type is Wide_Character
192 -- xx = Wide_Character
193 -- tv = Wide_Character (Expr)
194 -- pm = Boolean, true if Ada 2005 mode, False otherwise
196 -- For types whose root type is Wide_Wide_Character
197 -- xx = Wide_Wide_haracter
198 -- tv = Wide_Wide_Character (Expr)
200 -- For floating-point types
201 -- xx = Floating_Point
202 -- tv = Long_Long_Float (Expr)
205 -- For ordinary fixed-point types
206 -- xx = Ordinary_Fixed_Point
207 -- tv = Long_Long_Float (Expr)
210 -- For decimal fixed-point types with size = Integer'Size
212 -- tv = Integer (Expr)
215 -- For decimal fixed-point types with size > Integer'Size
216 -- xx = Long_Long_Decimal
217 -- tv = Long_Long_Integer (Expr)
220 -- Note: for the decimal fixed-point type cases, the conversion is
221 -- done literally without scaling (i.e. the actual expression that
222 -- is generated is Image_xx (tp?(Expr) [, pm])
224 -- For enumeration types other than those declared packages Standard
225 -- or System, typ'Image (X) expands into:
227 -- Image_Enumeration_NN (typ'Pos (X), typS, typI'Address)
229 -- where typS and typI are the entities constructed as described in
230 -- the spec for the procedure Build_Enumeration_Image_Tables and NN
231 -- is 32/16/8 depending on the element type of Lit_Indexes.
233 procedure Expand_Image_Attribute
(N
: Node_Id
) is
234 Loc
: constant Source_Ptr
:= Sloc
(N
);
235 Exprs
: constant List_Id
:= Expressions
(N
);
236 Pref
: constant Node_Id
:= Prefix
(N
);
237 Ptyp
: constant Entity_Id
:= Entity
(Pref
);
238 Rtyp
: constant Entity_Id
:= Root_Type
(Ptyp
);
239 Expr
: constant Node_Id
:= Relocate_Node
(First
(Exprs
));
245 Func_Ent
: Entity_Id
;
248 if Rtyp
= Standard_Boolean
then
249 Imid
:= RE_Image_Boolean
;
252 elsif Rtyp
= Standard_Character
then
253 Imid
:= RE_Image_Character
;
256 elsif Rtyp
= Standard_Wide_Character
then
257 Imid
:= RE_Image_Wide_Character
;
260 elsif Rtyp
= Standard_Wide_Wide_Character
then
261 Imid
:= RE_Image_Wide_Wide_Character
;
264 elsif Is_Signed_Integer_Type
(Rtyp
) then
265 if Esize
(Rtyp
) <= Esize
(Standard_Integer
) then
266 Imid
:= RE_Image_Integer
;
267 Tent
:= Standard_Integer
;
269 Imid
:= RE_Image_Long_Long_Integer
;
270 Tent
:= Standard_Long_Long_Integer
;
273 elsif Is_Modular_Integer_Type
(Rtyp
) then
274 if Modulus
(Rtyp
) <= Modulus
(RTE
(RE_Unsigned
)) then
275 Imid
:= RE_Image_Unsigned
;
276 Tent
:= RTE
(RE_Unsigned
);
278 Imid
:= RE_Image_Long_Long_Unsigned
;
279 Tent
:= RTE
(RE_Long_Long_Unsigned
);
282 elsif Is_Decimal_Fixed_Point_Type
(Rtyp
) then
283 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
284 Imid
:= RE_Image_Decimal
;
285 Tent
:= Standard_Integer
;
287 Imid
:= RE_Image_Long_Long_Decimal
;
288 Tent
:= Standard_Long_Long_Integer
;
291 elsif Is_Ordinary_Fixed_Point_Type
(Rtyp
) then
292 Imid
:= RE_Image_Ordinary_Fixed_Point
;
293 Tent
:= Standard_Long_Long_Float
;
295 elsif Is_Floating_Point_Type
(Rtyp
) then
296 Imid
:= RE_Image_Floating_Point
;
297 Tent
:= Standard_Long_Long_Float
;
299 -- Only other possibility is user defined enumeration type
302 if Discard_Names
(First_Subtype
(Ptyp
))
303 or else No
(Lit_Strings
(Root_Type
(Ptyp
)))
305 -- When pragma Discard_Names applies to the first subtype,
306 -- then build (Pref'Pos)'Img.
309 Make_Attribute_Reference
(Loc
,
311 Make_Attribute_Reference
(Loc
,
313 Attribute_Name
=> Name_Pos
,
314 Expressions
=> New_List
(Expr
)),
317 Analyze_And_Resolve
(N
, Standard_String
);
320 -- Here we get the Image of an enumeration type
322 Ttyp
:= Component_Type
(Etype
(Lit_Indexes
(Rtyp
)));
324 if Ttyp
= Standard_Integer_8
then
325 Func
:= RE_Image_Enumeration_8
;
326 elsif Ttyp
= Standard_Integer_16
then
327 Func
:= RE_Image_Enumeration_16
;
329 Func
:= RE_Image_Enumeration_32
;
332 -- Apply a validity check, since it is a bit drastic to
333 -- get a completely junk image value for an invalid value.
335 if not Expr_Known_Valid
(Expr
) then
336 Insert_Valid_Check
(Expr
);
340 Make_Function_Call
(Loc
,
341 Name
=> New_Occurrence_Of
(RTE
(Func
), Loc
),
342 Parameter_Associations
=> New_List
(
343 Make_Attribute_Reference
(Loc
,
344 Attribute_Name
=> Name_Pos
,
345 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
346 Expressions
=> New_List
(Expr
)),
347 New_Occurrence_Of
(Lit_Strings
(Rtyp
), Loc
),
348 Make_Attribute_Reference
(Loc
,
349 Prefix
=> New_Occurrence_Of
(Lit_Indexes
(Rtyp
), Loc
),
350 Attribute_Name
=> Name_Address
))));
352 Analyze_And_Resolve
(N
, Standard_String
);
358 -- If we fall through, we have one of the cases that is handled by
359 -- calling one of the System.Img_xx routines and Imid is set to the
360 -- RE_Id for the function to be called.
362 Func_Ent
:= RTE
(Imid
);
364 -- If the function entity is empty, that means we have a case in
365 -- no run time mode where the operation is not allowed, and an
366 -- appropriate diagnostic has already been issued.
368 if No
(Func_Ent
) then
372 -- Otherwise prepare arguments for run-time call
374 Arglist
:= New_List
(Convert_To
(Tent
, Relocate_Node
(Expr
)));
376 -- For floating-point types, append Digits argument
378 if Is_Floating_Point_Type
(Rtyp
) then
380 Make_Attribute_Reference
(Loc
,
381 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
382 Attribute_Name
=> Name_Digits
));
384 -- For ordinary fixed-point types, append Aft parameter
386 elsif Is_Ordinary_Fixed_Point_Type
(Rtyp
) then
388 Make_Attribute_Reference
(Loc
,
389 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
390 Attribute_Name
=> Name_Aft
));
392 -- For decimal, append Scale and also set to do literal conversion
394 elsif Is_Decimal_Fixed_Point_Type
(Rtyp
) then
396 Make_Attribute_Reference
(Loc
,
397 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
398 Attribute_Name
=> Name_Scale
));
400 Set_Conversion_OK
(First
(Arglist
));
401 Set_Etype
(First
(Arglist
), Tent
);
403 -- For Wide_Character, append Ada 2005 indication
405 elsif Rtyp
= Standard_Wide_Character
then
407 New_Reference_To
(Boolean_Literals
(Ada_Version
>= Ada_05
), Loc
));
411 Make_Function_Call
(Loc
,
412 Name
=> New_Reference_To
(Func_Ent
, Loc
),
413 Parameter_Associations
=> Arglist
));
415 Analyze_And_Resolve
(N
, Standard_String
);
416 end Expand_Image_Attribute
;
418 ----------------------------
419 -- Expand_Value_Attribute --
420 ----------------------------
422 -- For scalar types derived from Boolean, Character and integer types
423 -- in package Standard, typ'Value (X) expands into:
425 -- btyp (Value_xx (X))
427 -- where btyp is he base type of the prefix, and
429 -- For types whose root type is Character
432 -- For types whose root type is Wide_Character
433 -- xx = Wide_Character
435 -- For types whose root type is Wide_Wide_Character
436 -- xx = Wide_Wide_Character
438 -- For types whose root type is Boolean
441 -- For signed integer types with size <= Integer'Size
444 -- For other signed integer types
445 -- xx = Long_Long_Integer
447 -- For modular types with modulus <= System.Unsigned_Types.Unsigned
450 -- For other modular integer types
451 -- xx = Long_Long_Unsigned
453 -- For floating-point types and ordinary fixed-point types
456 -- For decimal types with size <= Integer'Size, typ'Value (X)
459 -- btyp?(Value_Decimal (X, typ'Scale));
461 -- For all other decimal types, typ'Value (X) expands into
463 -- btyp?(Value_Long_Long_Decimal (X, typ'Scale))
465 -- For enumeration types other than those derived from types Boolean,
466 -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
468 -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
470 -- where typS and typI and the Lit_Strings and Lit_Indexes entities
471 -- from T's root type entitym and Num is Enum'Pos (Enum'Last). The
472 -- Value_Enumeration_NN function will search the tables looking for
473 -- X and return the position number in the table if found which is
474 -- used to provide the result of 'Value (using Enum'Val). If the
475 -- value is not found Constraint_Error is raised. The suffix _NN
476 -- depends on the element type of typI.
478 procedure Expand_Value_Attribute
(N
: Node_Id
) is
479 Loc
: constant Source_Ptr
:= Sloc
(N
);
480 Typ
: constant Entity_Id
:= Etype
(N
);
481 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
482 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
483 Exprs
: constant List_Id
:= Expressions
(N
);
492 if Rtyp
= Standard_Character
then
493 Vid
:= RE_Value_Character
;
495 elsif Rtyp
= Standard_Boolean
then
496 Vid
:= RE_Value_Boolean
;
498 elsif Rtyp
= Standard_Wide_Character
then
499 Vid
:= RE_Value_Wide_Character
;
501 elsif Rtyp
= Standard_Wide_Wide_Character
then
502 Vid
:= RE_Value_Wide_Wide_Character
;
504 elsif Rtyp
= Base_Type
(Standard_Short_Short_Integer
)
505 or else Rtyp
= Base_Type
(Standard_Short_Integer
)
506 or else Rtyp
= Base_Type
(Standard_Integer
)
508 Vid
:= RE_Value_Integer
;
510 elsif Is_Signed_Integer_Type
(Rtyp
) then
511 Vid
:= RE_Value_Long_Long_Integer
;
513 elsif Is_Modular_Integer_Type
(Rtyp
) then
514 if Modulus
(Rtyp
) <= Modulus
(RTE
(RE_Unsigned
)) then
515 Vid
:= RE_Value_Unsigned
;
517 Vid
:= RE_Value_Long_Long_Unsigned
;
520 elsif Is_Decimal_Fixed_Point_Type
(Rtyp
) then
521 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
522 Vid
:= RE_Value_Decimal
;
524 Vid
:= RE_Value_Long_Long_Decimal
;
528 Make_Attribute_Reference
(Loc
,
529 Prefix
=> New_Reference_To
(Typ
, Loc
),
530 Attribute_Name
=> Name_Scale
));
534 Make_Function_Call
(Loc
,
535 Name
=> New_Reference_To
(RTE
(Vid
), Loc
),
536 Parameter_Associations
=> Args
)));
539 Analyze_And_Resolve
(N
, Btyp
);
542 elsif Is_Real_Type
(Rtyp
) then
543 Vid
:= RE_Value_Real
;
545 -- Only other possibility is user defined enumeration type
548 pragma Assert
(Is_Enumeration_Type
(Rtyp
));
550 -- Case of pragma Discard_Names, transform the Value
551 -- attribute to Btyp'Val (Long_Long_Integer'Value (Args))
553 if Discard_Names
(First_Subtype
(Typ
))
554 or else No
(Lit_Strings
(Rtyp
))
557 Make_Attribute_Reference
(Loc
,
558 Prefix
=> New_Reference_To
(Btyp
, Loc
),
559 Attribute_Name
=> Name_Val
,
560 Expressions
=> New_List
(
561 Make_Attribute_Reference
(Loc
,
563 New_Occurrence_Of
(Standard_Long_Long_Integer
, Loc
),
564 Attribute_Name
=> Name_Value
,
565 Expressions
=> Args
))));
567 Analyze_And_Resolve
(N
, Btyp
);
569 -- Here for normal case where we have enumeration tables, this
572 -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
575 Ttyp
:= Component_Type
(Etype
(Lit_Indexes
(Rtyp
)));
577 if Ttyp
= Standard_Integer_8
then
578 Func
:= RE_Value_Enumeration_8
;
579 elsif Ttyp
= Standard_Integer_16
then
580 Func
:= RE_Value_Enumeration_16
;
582 Func
:= RE_Value_Enumeration_32
;
586 Make_Attribute_Reference
(Loc
,
587 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
),
588 Attribute_Name
=> Name_Pos
,
589 Expressions
=> New_List
(
590 Make_Attribute_Reference
(Loc
,
591 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
),
592 Attribute_Name
=> Name_Last
))));
595 Make_Attribute_Reference
(Loc
,
596 Prefix
=> New_Occurrence_Of
(Lit_Indexes
(Rtyp
), Loc
),
597 Attribute_Name
=> Name_Address
));
600 New_Occurrence_Of
(Lit_Strings
(Rtyp
), Loc
));
603 Make_Attribute_Reference
(Loc
,
604 Prefix
=> New_Reference_To
(Typ
, Loc
),
605 Attribute_Name
=> Name_Val
,
606 Expressions
=> New_List
(
607 Make_Function_Call
(Loc
,
609 New_Reference_To
(RTE
(Func
), Loc
),
610 Parameter_Associations
=> Args
))));
612 Analyze_And_Resolve
(N
, Btyp
);
618 -- Fall through for all cases except user defined enumeration type
619 -- and decimal types, with Vid set to the Id of the entity for the
620 -- Value routine and Args set to the list of parameters for the call.
624 Make_Function_Call
(Loc
,
625 Name
=> New_Reference_To
(RTE
(Vid
), Loc
),
626 Parameter_Associations
=> Args
)));
628 Analyze_And_Resolve
(N
, Btyp
);
629 end Expand_Value_Attribute
;
631 ----------------------------
632 -- Expand_Width_Attribute --
633 ----------------------------
635 -- The processing here also handles the case of Wide_[Wide_]Width. With the
636 -- exceptions noted, the processing is identical
638 -- For scalar types derived from Boolean, character and integer types
639 -- in package Standard. Note that the Width attribute is computed at
640 -- compile time for all cases except those involving non-static sub-
641 -- types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
643 -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
647 -- For types whose root type is Character
648 -- xx = Width_Character
651 -- For types whose root type is Wide_Character
652 -- xx = Wide_Width_Character
655 -- For types whose root type is Wide_Wide_Character
656 -- xx = Wide_Wide_Width_Character
659 -- For types whose root type is Boolean
660 -- xx = Width_Boolean
663 -- For signed integer types
664 -- xx = Width_Long_Long_Integer
665 -- yy = Long_Long_Integer
667 -- For modular integer types
668 -- xx = Width_Long_Long_Unsigned
669 -- yy = Long_Long_Unsigned
671 -- For types derived from Wide_Character, typ'Width expands into
673 -- Result_Type (Width_Wide_Character (
674 -- Wide_Character (typ'First),
675 -- Wide_Character (typ'Last),
677 -- and typ'Wide_Width expands into:
679 -- Result_Type (Wide_Width_Wide_Character (
680 -- Wide_Character (typ'First),
681 -- Wide_Character (typ'Last));
683 -- and typ'Wide_Wide_Width expands into
685 -- Result_Type (Wide_Wide_Width_Wide_Character (
686 -- Wide_Character (typ'First),
687 -- Wide_Character (typ'Last));
689 -- For types derived from Wide_Wide_Character, typ'Width expands into
691 -- Result_Type (Width_Wide_Wide_Character (
692 -- Wide_Wide_Character (typ'First),
693 -- Wide_Wide_Character (typ'Last),
695 -- and typ'Wide_Width expands into:
697 -- Result_Type (Wide_Width_Wide_Wide_Character (
698 -- Wide_Wide_Character (typ'First),
699 -- Wide_Wide_Character (typ'Last));
701 -- and typ'Wide_Wide_Width expands into
703 -- Result_Type (Wide_Wide_Width_Wide_Wide_Char (
704 -- Wide_Wide_Character (typ'First),
705 -- Wide_Wide_Character (typ'Last));
707 -- For real types, typ'Width and typ'Wide_[Wide_]Width expand into
709 -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
711 -- where btyp is the base type. This looks recursive but it isn't
712 -- because the base type is always static, and hence the expression
713 -- in the else is reduced to an integer literal.
715 -- For user defined enumeration types, typ'Width expands into
717 -- Result_Type (Width_Enumeration_NN
720 -- typ'Pos (typ'First),
721 -- typ'Pos (Typ'Last)));
723 -- and typ'Wide_Width expands into:
725 -- Result_Type (Wide_Width_Enumeration_NN
728 -- typ'Pos (typ'First),
729 -- typ'Pos (Typ'Last))
730 -- Wide_Character_Encoding_Method);
732 -- and typ'Wide_Wide_Width expands into:
734 -- Result_Type (Wide_Wide_Width_Enumeration_NN
737 -- typ'Pos (typ'First),
738 -- typ'Pos (Typ'Last))
739 -- Wide_Character_Encoding_Method);
741 -- where typS and typI are the enumeration image strings and
742 -- indexes table, as described in Build_Enumeration_Image_Tables.
743 -- NN is 8/16/32 for depending on the element type for typI.
745 procedure Expand_Width_Attribute
(N
: Node_Id
; Attr
: Atype
:= Normal
) is
746 Loc
: constant Source_Ptr
:= Sloc
(N
);
747 Typ
: constant Entity_Id
:= Etype
(N
);
748 Pref
: constant Node_Id
:= Prefix
(N
);
749 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
750 Rtyp
: constant Entity_Id
:= Root_Type
(Ptyp
);
757 -- Types derived from Standard.Boolean
759 if Rtyp
= Standard_Boolean
then
760 XX
:= RE_Width_Boolean
;
763 -- Types derived from Standard.Character
765 elsif Rtyp
= Standard_Character
then
767 when Normal
=> XX
:= RE_Width_Character
;
768 when Wide
=> XX
:= RE_Wide_Width_Character
;
769 when Wide_Wide
=> XX
:= RE_Wide_Wide_Width_Character
;
774 -- Types derived from Standard.Wide_Character
776 elsif Rtyp
= Standard_Wide_Character
then
778 when Normal
=> XX
:= RE_Width_Wide_Character
;
779 when Wide
=> XX
:= RE_Wide_Width_Wide_Character
;
780 when Wide_Wide
=> XX
:= RE_Wide_Wide_Width_Wide_Character
;
785 -- Types derived from Standard.Wide_Wide_Character
787 elsif Rtyp
= Standard_Wide_Wide_Character
then
789 when Normal
=> XX
:= RE_Width_Wide_Wide_Character
;
790 when Wide
=> XX
:= RE_Wide_Width_Wide_Wide_Character
;
791 when Wide_Wide
=> XX
:= RE_Wide_Wide_Width_Wide_Wide_Char
;
796 -- Signed integer types
798 elsif Is_Signed_Integer_Type
(Rtyp
) then
799 XX
:= RE_Width_Long_Long_Integer
;
800 YY
:= Standard_Long_Long_Integer
;
802 -- Modular integer types
804 elsif Is_Modular_Integer_Type
(Rtyp
) then
805 XX
:= RE_Width_Long_Long_Unsigned
;
806 YY
:= RTE
(RE_Long_Long_Unsigned
);
810 elsif Is_Real_Type
(Rtyp
) then
813 Make_Conditional_Expression
(Loc
,
814 Expressions
=> New_List
(
818 Make_Attribute_Reference
(Loc
,
819 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
820 Attribute_Name
=> Name_First
),
823 Make_Attribute_Reference
(Loc
,
824 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
825 Attribute_Name
=> Name_Last
)),
827 Make_Integer_Literal
(Loc
, 0),
829 Make_Attribute_Reference
(Loc
,
830 Prefix
=> New_Reference_To
(Base_Type
(Ptyp
), Loc
),
831 Attribute_Name
=> Name_Width
))));
833 Analyze_And_Resolve
(N
, Typ
);
836 -- User defined enumeration types
839 pragma Assert
(Is_Enumeration_Type
(Rtyp
));
841 if Discard_Names
(Rtyp
) then
843 -- This is a configurable run-time, or else a restriction is in
844 -- effect. In either case the attribute cannot be supported. Force
845 -- a load error from Rtsfind to generate an appropriate message,
846 -- as is done with other ZFP violations.
849 pragma Warnings
(Off
); -- since Discard is unreferenced
850 Discard
: constant Entity_Id
:= RTE
(RE_Null
);
851 pragma Warnings
(On
);
857 Ttyp
:= Component_Type
(Etype
(Lit_Indexes
(Rtyp
)));
861 if Ttyp
= Standard_Integer_8
then
862 XX
:= RE_Width_Enumeration_8
;
863 elsif Ttyp
= Standard_Integer_16
then
864 XX
:= RE_Width_Enumeration_16
;
866 XX
:= RE_Width_Enumeration_32
;
870 if Ttyp
= Standard_Integer_8
then
871 XX
:= RE_Wide_Width_Enumeration_8
;
872 elsif Ttyp
= Standard_Integer_16
then
873 XX
:= RE_Wide_Width_Enumeration_16
;
875 XX
:= RE_Wide_Width_Enumeration_32
;
879 if Ttyp
= Standard_Integer_8
then
880 XX
:= RE_Wide_Wide_Width_Enumeration_8
;
881 elsif Ttyp
= Standard_Integer_16
then
882 XX
:= RE_Wide_Wide_Width_Enumeration_16
;
884 XX
:= RE_Wide_Wide_Width_Enumeration_32
;
890 New_Occurrence_Of
(Lit_Strings
(Rtyp
), Loc
),
892 Make_Attribute_Reference
(Loc
,
893 Prefix
=> New_Occurrence_Of
(Lit_Indexes
(Rtyp
), Loc
),
894 Attribute_Name
=> Name_Address
),
896 Make_Attribute_Reference
(Loc
,
897 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
898 Attribute_Name
=> Name_Pos
,
900 Expressions
=> New_List
(
901 Make_Attribute_Reference
(Loc
,
902 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
903 Attribute_Name
=> Name_First
))),
905 Make_Attribute_Reference
(Loc
,
906 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
907 Attribute_Name
=> Name_Pos
,
909 Expressions
=> New_List
(
910 Make_Attribute_Reference
(Loc
,
911 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
912 Attribute_Name
=> Name_Last
))));
916 Make_Function_Call
(Loc
,
917 Name
=> New_Reference_To
(RTE
(XX
), Loc
),
918 Parameter_Associations
=> Arglist
)));
920 Analyze_And_Resolve
(N
, Typ
);
924 -- If we fall through XX and YY are set
926 Arglist
:= New_List
(
928 Make_Attribute_Reference
(Loc
,
929 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
930 Attribute_Name
=> Name_First
)),
933 Make_Attribute_Reference
(Loc
,
934 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
935 Attribute_Name
=> Name_Last
)));
939 Make_Function_Call
(Loc
,
940 Name
=> New_Reference_To
(RTE
(XX
), Loc
),
941 Parameter_Associations
=> Arglist
)));
943 Analyze_And_Resolve
(N
, Typ
);
944 end Expand_Width_Attribute
;