1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2006, 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
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 Wide_[Wide_]Character types, typ'Value (X) expands into:
458 -- btyp (Value_xx (X, EM))
460 -- where btyp is the base type of the prefix, and EM is the encoding method
462 -- For decimal types with size <= Integer'Size, typ'Value (X)
465 -- btyp?(Value_Decimal (X, typ'Scale));
467 -- For all other decimal types, typ'Value (X) expands into
469 -- btyp?(Value_Long_Long_Decimal (X, typ'Scale))
471 -- For enumeration types other than those derived from types Boolean,
472 -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
474 -- Enum'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
476 -- where typS and typI and the Lit_Strings and Lit_Indexes entities
477 -- from T's root type entitym and Num is Enum'Pos (Enum'Last). The
478 -- Value_Enumeration_NN function will search the tables looking for
479 -- X and return the position number in the table if found which is
480 -- used to provide the result of 'Value (using Enum'Val). If the
481 -- value is not found Constraint_Error is raised. The suffix _NN
482 -- depends on the element type of typI.
484 procedure Expand_Value_Attribute
(N
: Node_Id
) is
485 Loc
: constant Source_Ptr
:= Sloc
(N
);
486 Typ
: constant Entity_Id
:= Etype
(N
);
487 Btyp
: constant Entity_Id
:= Base_Type
(Typ
);
488 Rtyp
: constant Entity_Id
:= Root_Type
(Typ
);
489 Exprs
: constant List_Id
:= Expressions
(N
);
498 if Rtyp
= Standard_Character
then
499 Vid
:= RE_Value_Character
;
501 elsif Rtyp
= Standard_Boolean
then
502 Vid
:= RE_Value_Boolean
;
504 elsif Rtyp
= Standard_Wide_Character
then
505 Vid
:= RE_Value_Wide_Character
;
508 Make_Integer_Literal
(Loc
,
509 Intval
=> Int
(Wide_Character_Encoding_Method
)));
511 elsif Rtyp
= Standard_Wide_Wide_Character
then
512 Vid
:= RE_Value_Wide_Wide_Character
;
515 Make_Integer_Literal
(Loc
,
516 Intval
=> Int
(Wide_Character_Encoding_Method
)));
518 elsif Rtyp
= Base_Type
(Standard_Short_Short_Integer
)
519 or else Rtyp
= Base_Type
(Standard_Short_Integer
)
520 or else Rtyp
= Base_Type
(Standard_Integer
)
522 Vid
:= RE_Value_Integer
;
524 elsif Is_Signed_Integer_Type
(Rtyp
) then
525 Vid
:= RE_Value_Long_Long_Integer
;
527 elsif Is_Modular_Integer_Type
(Rtyp
) then
528 if Modulus
(Rtyp
) <= Modulus
(RTE
(RE_Unsigned
)) then
529 Vid
:= RE_Value_Unsigned
;
531 Vid
:= RE_Value_Long_Long_Unsigned
;
534 elsif Is_Decimal_Fixed_Point_Type
(Rtyp
) then
535 if UI_To_Int
(Esize
(Rtyp
)) <= Standard_Integer_Size
then
536 Vid
:= RE_Value_Decimal
;
538 Vid
:= RE_Value_Long_Long_Decimal
;
542 Make_Attribute_Reference
(Loc
,
543 Prefix
=> New_Reference_To
(Typ
, Loc
),
544 Attribute_Name
=> Name_Scale
));
548 Make_Function_Call
(Loc
,
549 Name
=> New_Reference_To
(RTE
(Vid
), Loc
),
550 Parameter_Associations
=> Args
)));
553 Analyze_And_Resolve
(N
, Btyp
);
556 elsif Is_Real_Type
(Rtyp
) then
557 Vid
:= RE_Value_Real
;
559 -- Only other possibility is user defined enumeration type
562 pragma Assert
(Is_Enumeration_Type
(Rtyp
));
564 -- Case of pragma Discard_Names, transform the Value
565 -- attribute to Btyp'Val (Long_Long_Integer'Value (Args))
567 if Discard_Names
(First_Subtype
(Typ
))
568 or else No
(Lit_Strings
(Rtyp
))
571 Make_Attribute_Reference
(Loc
,
572 Prefix
=> New_Reference_To
(Btyp
, Loc
),
573 Attribute_Name
=> Name_Val
,
574 Expressions
=> New_List
(
575 Make_Attribute_Reference
(Loc
,
577 New_Occurrence_Of
(Standard_Long_Long_Integer
, Loc
),
578 Attribute_Name
=> Name_Value
,
579 Expressions
=> Args
))));
581 Analyze_And_Resolve
(N
, Btyp
);
583 -- Here for normal case where we have enumeration tables, this
586 -- T'Val (Value_Enumeration_NN (typS, typI'Address, Num, X))
589 Ttyp
:= Component_Type
(Etype
(Lit_Indexes
(Rtyp
)));
591 if Ttyp
= Standard_Integer_8
then
592 Func
:= RE_Value_Enumeration_8
;
593 elsif Ttyp
= Standard_Integer_16
then
594 Func
:= RE_Value_Enumeration_16
;
596 Func
:= RE_Value_Enumeration_32
;
600 Make_Attribute_Reference
(Loc
,
601 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
),
602 Attribute_Name
=> Name_Pos
,
603 Expressions
=> New_List
(
604 Make_Attribute_Reference
(Loc
,
605 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
),
606 Attribute_Name
=> Name_Last
))));
609 Make_Attribute_Reference
(Loc
,
610 Prefix
=> New_Occurrence_Of
(Lit_Indexes
(Rtyp
), Loc
),
611 Attribute_Name
=> Name_Address
));
614 New_Occurrence_Of
(Lit_Strings
(Rtyp
), Loc
));
617 Make_Attribute_Reference
(Loc
,
618 Prefix
=> New_Reference_To
(Typ
, Loc
),
619 Attribute_Name
=> Name_Val
,
620 Expressions
=> New_List
(
621 Make_Function_Call
(Loc
,
623 New_Reference_To
(RTE
(Func
), Loc
),
624 Parameter_Associations
=> Args
))));
626 Analyze_And_Resolve
(N
, Btyp
);
632 -- Fall through for all cases except user defined enumeration type
633 -- and decimal types, with Vid set to the Id of the entity for the
634 -- Value routine and Args set to the list of parameters for the call.
638 Make_Function_Call
(Loc
,
639 Name
=> New_Reference_To
(RTE
(Vid
), Loc
),
640 Parameter_Associations
=> Args
)));
642 Analyze_And_Resolve
(N
, Btyp
);
643 end Expand_Value_Attribute
;
645 ----------------------------
646 -- Expand_Width_Attribute --
647 ----------------------------
649 -- The processing here also handles the case of Wide_[Wide_]Width. With the
650 -- exceptions noted, the processing is identical
652 -- For scalar types derived from Boolean, character and integer types
653 -- in package Standard. Note that the Width attribute is computed at
654 -- compile time for all cases except those involving non-static sub-
655 -- types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
657 -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
661 -- For types whose root type is Character
662 -- xx = Width_Character
665 -- For types whose root type is Wide_Character
666 -- xx = Wide_Width_Character
669 -- For types whose root type is Wide_Wide_Character
670 -- xx = Wide_Wide_Width_Character
673 -- For types whose root type is Boolean
674 -- xx = Width_Boolean
677 -- For signed integer types
678 -- xx = Width_Long_Long_Integer
679 -- yy = Long_Long_Integer
681 -- For modular integer types
682 -- xx = Width_Long_Long_Unsigned
683 -- yy = Long_Long_Unsigned
685 -- For types derived from Wide_Character, typ'Width expands into
687 -- Result_Type (Width_Wide_Character (
688 -- Wide_Character (typ'First),
689 -- Wide_Character (typ'Last),
691 -- and typ'Wide_Width expands into:
693 -- Result_Type (Wide_Width_Wide_Character (
694 -- Wide_Character (typ'First),
695 -- Wide_Character (typ'Last));
697 -- and typ'Wide_Wide_Width expands into
699 -- Result_Type (Wide_Wide_Width_Wide_Character (
700 -- Wide_Character (typ'First),
701 -- Wide_Character (typ'Last));
703 -- For types derived from Wide_Wide_Character, typ'Width expands into
705 -- Result_Type (Width_Wide_Wide_Character (
706 -- Wide_Wide_Character (typ'First),
707 -- Wide_Wide_Character (typ'Last),
709 -- and typ'Wide_Width expands into:
711 -- Result_Type (Wide_Width_Wide_Wide_Character (
712 -- Wide_Wide_Character (typ'First),
713 -- Wide_Wide_Character (typ'Last));
715 -- and typ'Wide_Wide_Width expands into
717 -- Result_Type (Wide_Wide_Width_Wide_Wide_Char (
718 -- Wide_Wide_Character (typ'First),
719 -- Wide_Wide_Character (typ'Last));
721 -- For real types, typ'Width and typ'Wide_[Wide_]Width expand into
723 -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
725 -- where btyp is the base type. This looks recursive but it isn't
726 -- because the base type is always static, and hence the expression
727 -- in the else is reduced to an integer literal.
729 -- For user defined enumeration types, typ'Width expands into
731 -- Result_Type (Width_Enumeration_NN
734 -- typ'Pos (typ'First),
735 -- typ'Pos (Typ'Last)));
737 -- and typ'Wide_Width expands into:
739 -- Result_Type (Wide_Width_Enumeration_NN
742 -- typ'Pos (typ'First),
743 -- typ'Pos (Typ'Last))
744 -- Wide_Character_Encoding_Method);
746 -- and typ'Wide_Wide_Width expands into:
748 -- Result_Type (Wide_Wide_Width_Enumeration_NN
751 -- typ'Pos (typ'First),
752 -- typ'Pos (Typ'Last))
753 -- Wide_Character_Encoding_Method);
755 -- where typS and typI are the enumeration image strings and
756 -- indexes table, as described in Build_Enumeration_Image_Tables.
757 -- NN is 8/16/32 for depending on the element type for typI.
759 procedure Expand_Width_Attribute
(N
: Node_Id
; Attr
: Atype
:= Normal
) is
760 Loc
: constant Source_Ptr
:= Sloc
(N
);
761 Typ
: constant Entity_Id
:= Etype
(N
);
762 Pref
: constant Node_Id
:= Prefix
(N
);
763 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
764 Rtyp
: constant Entity_Id
:= Root_Type
(Ptyp
);
771 -- Types derived from Standard.Boolean
773 if Rtyp
= Standard_Boolean
then
774 XX
:= RE_Width_Boolean
;
777 -- Types derived from Standard.Character
779 elsif Rtyp
= Standard_Character
then
781 when Normal
=> XX
:= RE_Width_Character
;
782 when Wide
=> XX
:= RE_Wide_Width_Character
;
783 when Wide_Wide
=> XX
:= RE_Wide_Wide_Width_Character
;
788 -- Types derived from Standard.Wide_Character
790 elsif Rtyp
= Standard_Wide_Character
then
792 when Normal
=> XX
:= RE_Width_Wide_Character
;
793 when Wide
=> XX
:= RE_Wide_Width_Wide_Character
;
794 when Wide_Wide
=> XX
:= RE_Wide_Wide_Width_Wide_Character
;
799 -- Types derived from Standard.Wide_Wide_Character
801 elsif Rtyp
= Standard_Wide_Wide_Character
then
803 when Normal
=> XX
:= RE_Width_Wide_Wide_Character
;
804 when Wide
=> XX
:= RE_Wide_Width_Wide_Wide_Character
;
805 when Wide_Wide
=> XX
:= RE_Wide_Wide_Width_Wide_Wide_Char
;
810 -- Signed integer types
812 elsif Is_Signed_Integer_Type
(Rtyp
) then
813 XX
:= RE_Width_Long_Long_Integer
;
814 YY
:= Standard_Long_Long_Integer
;
816 -- Modular integer types
818 elsif Is_Modular_Integer_Type
(Rtyp
) then
819 XX
:= RE_Width_Long_Long_Unsigned
;
820 YY
:= RTE
(RE_Long_Long_Unsigned
);
824 elsif Is_Real_Type
(Rtyp
) then
827 Make_Conditional_Expression
(Loc
,
828 Expressions
=> New_List
(
832 Make_Attribute_Reference
(Loc
,
833 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
834 Attribute_Name
=> Name_First
),
837 Make_Attribute_Reference
(Loc
,
838 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
839 Attribute_Name
=> Name_Last
)),
841 Make_Integer_Literal
(Loc
, 0),
843 Make_Attribute_Reference
(Loc
,
844 Prefix
=> New_Reference_To
(Base_Type
(Ptyp
), Loc
),
845 Attribute_Name
=> Name_Width
))));
847 Analyze_And_Resolve
(N
, Typ
);
850 -- User defined enumeration types
853 pragma Assert
(Is_Enumeration_Type
(Rtyp
));
855 if Discard_Names
(Rtyp
) then
857 -- This is a configurable run-time, or else a restriction is in
858 -- effect. In either case the attribute cannot be supported. Force
859 -- a load error from Rtsfind to generate an appropriate message,
860 -- as is done with other ZFP violations.
863 pragma Warnings
(Off
); -- since Discard is unreferenced
864 Discard
: constant Entity_Id
:= RTE
(RE_Null
);
865 pragma Warnings
(On
);
871 Ttyp
:= Component_Type
(Etype
(Lit_Indexes
(Rtyp
)));
875 if Ttyp
= Standard_Integer_8
then
876 XX
:= RE_Width_Enumeration_8
;
877 elsif Ttyp
= Standard_Integer_16
then
878 XX
:= RE_Width_Enumeration_16
;
880 XX
:= RE_Width_Enumeration_32
;
884 if Ttyp
= Standard_Integer_8
then
885 XX
:= RE_Wide_Width_Enumeration_8
;
886 elsif Ttyp
= Standard_Integer_16
then
887 XX
:= RE_Wide_Width_Enumeration_16
;
889 XX
:= RE_Wide_Width_Enumeration_32
;
893 if Ttyp
= Standard_Integer_8
then
894 XX
:= RE_Wide_Wide_Width_Enumeration_8
;
895 elsif Ttyp
= Standard_Integer_16
then
896 XX
:= RE_Wide_Wide_Width_Enumeration_16
;
898 XX
:= RE_Wide_Wide_Width_Enumeration_32
;
904 New_Occurrence_Of
(Lit_Strings
(Rtyp
), Loc
),
906 Make_Attribute_Reference
(Loc
,
907 Prefix
=> New_Occurrence_Of
(Lit_Indexes
(Rtyp
), Loc
),
908 Attribute_Name
=> Name_Address
),
910 Make_Attribute_Reference
(Loc
,
911 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
912 Attribute_Name
=> Name_Pos
,
914 Expressions
=> New_List
(
915 Make_Attribute_Reference
(Loc
,
916 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
917 Attribute_Name
=> Name_First
))),
919 Make_Attribute_Reference
(Loc
,
920 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
921 Attribute_Name
=> Name_Pos
,
923 Expressions
=> New_List
(
924 Make_Attribute_Reference
(Loc
,
925 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
926 Attribute_Name
=> Name_Last
))));
930 Make_Function_Call
(Loc
,
931 Name
=> New_Reference_To
(RTE
(XX
), Loc
),
932 Parameter_Associations
=> Arglist
)));
934 Analyze_And_Resolve
(N
, Typ
);
938 -- If we fall through XX and YY are set
940 Arglist
:= New_List
(
942 Make_Attribute_Reference
(Loc
,
943 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
944 Attribute_Name
=> Name_First
)),
947 Make_Attribute_Reference
(Loc
,
948 Prefix
=> New_Reference_To
(Ptyp
, Loc
),
949 Attribute_Name
=> Name_Last
)));
953 Make_Function_Call
(Loc
,
954 Name
=> New_Reference_To
(RTE
(XX
), Loc
),
955 Parameter_Associations
=> Arglist
)));
957 Analyze_And_Resolve
(N
, Typ
);
958 end Expand_Width_Attribute
;