1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2001-2022, 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 Einfo
.Entities
; use Einfo
.Entities
;
31 with Einfo
.Utils
; use Einfo
.Utils
;
32 with Debug
; use Debug
;
34 with Exp_Util
; use Exp_Util
;
36 with Namet
; use Namet
;
37 with Nmake
; use Nmake
;
38 with Nlists
; use Nlists
;
40 with Restrict
; use Restrict
;
41 with Rident
; use Rident
;
42 with Rtsfind
; use Rtsfind
;
43 with Sem_Aux
; use Sem_Aux
;
44 with Sem_Res
; use Sem_Res
;
45 with Sem_Util
; use Sem_Util
;
46 with Sinfo
; use Sinfo
;
47 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
48 with Sinfo
.Utils
; use Sinfo
.Utils
;
49 with Snames
; use Snames
;
50 with Stand
; use Stand
;
51 with Stringt
; use Stringt
;
52 with Targparm
; use Targparm
;
53 with Tbuild
; use Tbuild
;
54 with Ttypes
; use Ttypes
;
55 with Uintp
; use Uintp
;
56 with Urealp
; use Urealp
;
58 with System
.Perfect_Hash_Generators
;
60 package body Exp_Imgv
is
62 procedure Rewrite_Object_Image
67 -- AI12-0124: Rewrite attribute 'Image when it is applied to an object
68 -- reference as an attribute applied to a type. N denotes the node to be
69 -- rewritten, Pref denotes the prefix of the 'Image attribute, and Name
70 -- and Str_Typ specify which specific string type and 'Image attribute to
71 -- apply (e.g. Name_Wide_Image and Standard_Wide_String).
73 ------------------------------------
74 -- Build_Enumeration_Image_Tables --
75 ------------------------------------
77 procedure Build_Enumeration_Image_Tables
(E
: Entity_Id
; N
: Node_Id
) is
78 Loc
: constant Source_Ptr
:= Sloc
(E
);
79 In_Main_Unit
: constant Boolean := In_Extended_Main_Code_Unit
(Loc
);
96 package SPHG
renames System
.Perfect_Hash_Generators
;
98 Saved_SSO
: constant Character := Opt
.Default_SSO
;
99 -- Used to save the current scalar storage order during the generation
100 -- of the literal lookup table.
102 Serial_Number_Budget
: constant := 50;
103 -- We may want to compute a perfect hash function for use by the Value
104 -- attribute. However computing this function is costly and, therefore,
105 -- cannot be done when compiling every unit where the enumeration type
106 -- is referenced, so we do it only when compiling the unit where it is
107 -- declared. This means that we may need to control the internal serial
108 -- numbers of this unit, or else we would risk generating public symbols
109 -- with mismatched names later on. The strategy for this is to allocate
110 -- a fixed budget of serial numbers to be spent from a specified point
111 -- until the end of the processing and to make sure that it is always
112 -- exactly spent on all possible paths from this point.
114 Threshold
: constant Nat
:=
115 (if Is_Library_Level_Entity
(E
)
116 or else not Always_Compatible_Rep_On_Target
119 -- Threshold above which we want to generate the hash function in the
120 -- default case. We avoid doing it if this would cause a trampoline to
121 -- be generated because the type is local and descriptors are not used.
123 Threshold_For_Size
: constant Nat
:= Nat
'Max (Threshold
, 9);
124 -- But the function and its tables take a bit of space so the threshold
125 -- is raised when compiling for size.
127 procedure Append_Table_To
133 -- Append to L the declaration of E as a constant array of range 0 .. UB
134 -- and component type Ctyp with initial value V.
136 ---------------------
137 -- Append_Table_To --
138 ---------------------
140 procedure Append_Table_To
149 Make_Object_Declaration
(Loc
,
150 Defining_Identifier
=> E
,
151 Constant_Present
=> True,
153 Make_Constrained_Array_Definition
(Loc
,
154 Discrete_Subtype_Definitions
=> New_List
(
156 Low_Bound
=> Make_Integer_Literal
(Loc
, 0),
157 High_Bound
=> Make_Integer_Literal
(Loc
, UB
))),
158 Component_Definition
=>
159 Make_Component_Definition
(Loc
,
160 Aliased_Present
=> False,
161 Subtype_Indication
=> New_Occurrence_Of
(Ctyp
, Loc
))),
162 Expression
=> Make_Aggregate
(Loc
, Expressions
=> V
,
163 Is_Enum_Array_Aggregate
=> True)));
166 -- Start of Build_Enumeration_Image_Tables
169 -- Nothing to do for types other than a root enumeration type
171 if E
/= Root_Type
(E
) then
174 -- Nothing to do if pragma Discard_Names applies
176 elsif Discard_Names
(E
) then
180 -- Otherwise tables need constructing
184 Lit
:= First_Literal
(E
);
190 Append_To
(Ind
, Make_Integer_Literal
(Loc
, UI_From_Int
(Len
)));
195 Get_Unqualified_Decoded_Name_String
(Chars
(Lit
));
197 if Name_Buffer
(1) /= ''' then
198 Set_Casing
(All_Upper_Case
);
201 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
203 SPHG
.Insert
(Name_Buffer
(1 .. Name_Len
));
205 Len
:= Len
+ Int
(Name_Len
);
209 if Len
< Int
(2 ** (8 - 1)) then
210 Ityp
:= Standard_Integer_8
;
211 elsif Len
< Int
(2 ** (16 - 1)) then
212 Ityp
:= Standard_Integer_16
;
214 Ityp
:= Standard_Integer_32
;
220 Make_Defining_Identifier
(Loc
,
221 Chars
=> New_External_Name
(Chars
(E
), 'S'));
224 Make_Defining_Identifier
(Loc
,
225 Chars
=> New_External_Name
(Chars
(E
), 'N'));
227 Set_Lit_Strings
(E
, Estr
);
228 Set_Lit_Indexes
(E
, Eind
);
230 -- Temporarily set the current scalar storage order to the default
231 -- during the generation of the literals table, since both the Image and
232 -- Value attributes rely on runtime routines for interpreting table
235 Opt
.Default_SSO
:= ' ';
237 -- Generate literal table
241 Make_Object_Declaration
(Loc
,
242 Defining_Identifier
=> Estr
,
243 Constant_Present
=> True,
245 New_Occurrence_Of
(Standard_String
, Loc
),
247 Make_String_Literal
(Loc
,
250 -- Generate index table
252 Append_Table_To
(Act
, Eind
, Nlit
, Ityp
, Ind
);
254 -- If the number of literals is not greater than Threshold, then we are
255 -- done. Otherwise we generate a (perfect) hash function for use by the
258 if Nlit
> Threshold
then
259 -- We start to count serial numbers from here
261 S_N
:= Increment_Serial_Number
;
263 -- Generate specification of hash function
266 Make_Defining_Identifier
(Loc
,
267 Chars
=> New_External_Name
(Chars
(E
), 'H'));
268 Mutate_Ekind
(H_Id
, E_Function
);
269 Set_Is_Internal
(H_Id
);
271 if not Debug_Generated_Code
then
272 Set_Debug_Info_Off
(H_Id
);
275 Set_Lit_Hash
(E
, H_Id
);
277 S_Id
:= Make_Temporary
(Loc
, 'S');
279 H_Sp
:= Make_Function_Specification
(Loc
,
280 Defining_Unit_Name
=> H_Id
,
281 Parameter_Specifications
=> New_List
(
282 Make_Parameter_Specification
(Loc
,
283 Defining_Identifier
=> S_Id
,
285 New_Occurrence_Of
(Standard_String
, Loc
))),
287 New_Occurrence_Of
(Standard_Natural
, Loc
));
289 -- If the unit where the type is declared is the main unit, and the
290 -- number of literals is greater than Threshold_For_Size when we are
291 -- optimizing for size, and the restriction No_Implicit_Loops is not
292 -- active, and -gnatd_h is not specified, and not GNAT_Mode, generate
293 -- the hash function.
296 and then (Optimize_Size
= 0 or else Nlit
> Threshold_For_Size
)
297 and then not Restriction_Active
(No_Implicit_Loops
)
298 and then not Debug_Flag_Underscore_H
299 and then not GNAT_Mode
302 LB
: constant Positive := 2 * Positive (Nlit
) + 1;
303 UB
: constant Positive := LB
+ 24;
306 -- Try at most 25 * 4 times to compute the hash function before
307 -- giving up and using a linear search for the Value attribute.
309 for V
in LB
.. UB
loop
311 SPHG
.Initialize
(4321, V
, SPHG
.Memory_Space
, Tries
=> 4);
316 when SPHG
.Too_Many_Tries
=> null;
322 -- If the hash function has been successfully computed, 4 more tables
323 -- named P, T1, T2 and G are needed. The hash function is of the form
325 -- function Hash (S : String) return Natural is
326 -- xxxP : constant array (0 .. X) of Natural = [...];
327 -- xxxT1 : constant array (0 .. Y) of Index_Type = [...];
328 -- xxxT2 : constant array (0 .. Y) of Index_Type = [...];
329 -- xxxG : constant array (0 .. Z) of Index_Type = [...];
331 -- F : constant Natural := S'First - 1;
332 -- L : constant Natural := S'Length;
333 -- A, B : Natural := 0;
337 -- for K in P'Range loop
338 -- exit when L < P (K);
339 -- J := Character'Pos (S (P (K) + F));
340 -- A := (A + Natural (T1 (K) * J)) mod N;
341 -- B := (B + Natural (T2 (K) * J)) mod N;
344 -- return (Natural (G (A)) + Natural (G (B))) mod M;
347 -- where N is the length of G and M the number of literals. Note that
348 -- we declare the tables inside the function for two reasons: first,
349 -- their analysis creates array subtypes and thus their concatenation
350 -- operators which are homonyms of the concatenation operator and may
351 -- change the homonym number of user operators declared in the scope;
352 -- second, the code generator can fold the values in the tables when
353 -- they are small and avoid emitting them in the final object code.
357 Siz
, L1
, L2
: Natural;
360 Pos
, T1
, T2
, G
: List_Id
;
361 EPos
, ET1
, ET2
, EG
: Entity_Id
;
363 F
, L
, A
, B
, J
, K
: Entity_Id
;
364 Body_Decls
: List_Id
;
365 Body_Stmts
: List_Id
;
366 Loop_Stmts
: List_Id
;
369 Body_Decls
:= New_List
;
371 -- Generate position table
373 SPHG
.Define
(SPHG
.Character_Position
, Siz
, L1
, L2
);
375 for J
in 0 .. L1
- 1 loop
376 I
:= Int
(SPHG
.Value
(SPHG
.Character_Position
, J
));
377 Append_To
(Pos
, Make_Integer_Literal
(Loc
, UI_From_Int
(I
)));
381 Make_Defining_Identifier
(Loc
,
382 Chars
=> New_External_Name
(Chars
(E
), 'P'));
385 (Body_Decls
, EPos
, Nat
(L1
- 1), Standard_Natural
, Pos
);
387 -- Generate function table 1
389 SPHG
.Define
(SPHG
.Function_Table_1
, Siz
, L1
, L2
);
391 for J
in 0 .. L1
- 1 loop
392 I
:= Int
(SPHG
.Value
(SPHG
.Function_Table_1
, J
));
393 Append_To
(T1
, Make_Integer_Literal
(Loc
, UI_From_Int
(I
)));
397 Make_Defining_Identifier
(Loc
,
398 Chars
=> New_External_Name
(Chars
(E
), "T1"));
401 Small_Integer_Type_For
(UI_From_Int
(Int
(Siz
)), Uns
=> True);
402 Append_Table_To
(Body_Decls
, ET1
, Nat
(L1
- 1), Ityp
, T1
);
404 -- Generate function table 2
406 SPHG
.Define
(SPHG
.Function_Table_2
, Siz
, L1
, L2
);
408 for J
in 0 .. L1
- 1 loop
409 I
:= Int
(SPHG
.Value
(SPHG
.Function_Table_2
, J
));
410 Append_To
(T2
, Make_Integer_Literal
(Loc
, UI_From_Int
(I
)));
414 Make_Defining_Identifier
(Loc
,
415 Chars
=> New_External_Name
(Chars
(E
), "T2"));
418 Small_Integer_Type_For
(UI_From_Int
(Int
(Siz
)), Uns
=> True);
419 Append_Table_To
(Body_Decls
, ET2
, Nat
(L1
- 1), Ityp
, T2
);
421 -- Generate graph table
423 SPHG
.Define
(SPHG
.Graph_Table
, Siz
, L1
, L2
);
425 for J
in 0 .. L1
- 1 loop
426 I
:= Int
(SPHG
.Value
(SPHG
.Graph_Table
, J
));
427 Append_To
(G
, Make_Integer_Literal
(Loc
, UI_From_Int
(I
)));
431 Make_Defining_Identifier
(Loc
,
432 Chars
=> New_External_Name
(Chars
(E
), 'G'));
435 Small_Integer_Type_For
(UI_From_Int
(Int
(Siz
)), Uns
=> True);
436 Append_Table_To
(Body_Decls
, EG
, Nat
(L1
- 1), Ityp
, G
);
438 F
:= Make_Temporary
(Loc
, 'F');
440 Append_To
(Body_Decls
,
441 Make_Object_Declaration
(Loc
,
442 Defining_Identifier
=> F
,
444 New_Occurrence_Of
(Standard_Natural
, Loc
),
446 Make_Op_Subtract
(Loc
,
448 Make_Attribute_Reference
(Loc
,
449 Prefix
=> New_Occurrence_Of
(S_Id
, Loc
),
450 Attribute_Name
=> Name_First
),
452 Make_Integer_Literal
(Loc
, 1))));
454 L
:= Make_Temporary
(Loc
, 'L');
456 Append_To
(Body_Decls
,
457 Make_Object_Declaration
(Loc
,
458 Defining_Identifier
=> L
,
460 New_Occurrence_Of
(Standard_Natural
, Loc
),
462 Make_Attribute_Reference
(Loc
,
463 Prefix
=> New_Occurrence_Of
(S_Id
, Loc
),
464 Attribute_Name
=> Name_Length
)));
466 A
:= Make_Temporary
(Loc
, 'A');
468 Append_To
(Body_Decls
,
469 Make_Object_Declaration
(Loc
,
470 Defining_Identifier
=> A
,
472 New_Occurrence_Of
(Standard_Natural
, Loc
),
473 Expression
=> Make_Integer_Literal
(Loc
, 0)));
475 B
:= Make_Temporary
(Loc
, 'B');
477 Append_To
(Body_Decls
,
478 Make_Object_Declaration
(Loc
,
479 Defining_Identifier
=> B
,
481 New_Occurrence_Of
(Standard_Natural
, Loc
),
482 Expression
=> Make_Integer_Literal
(Loc
, 0)));
484 J
:= Make_Temporary
(Loc
, 'J');
486 Append_To
(Body_Decls
,
487 Make_Object_Declaration
(Loc
,
488 Defining_Identifier
=> J
,
490 New_Occurrence_Of
(Standard_Natural
, Loc
)));
492 K
:= Make_Temporary
(Loc
, 'K');
494 -- Generate exit when L < P (K);
496 Loop_Stmts
:= New_List
(
497 Make_Exit_Statement
(Loc
,
500 Left_Opnd
=> New_Occurrence_Of
(L
, Loc
),
502 Make_Indexed_Component
(Loc
,
503 Prefix
=> New_Occurrence_Of
(EPos
, Loc
),
504 Expressions
=> New_List
(
505 New_Occurrence_Of
(K
, Loc
))))));
507 -- Generate J := Character'Pos (S (P (K) + F));
509 Append_To
(Loop_Stmts
,
510 Make_Assignment_Statement
(Loc
,
511 Name
=> New_Occurrence_Of
(J
, Loc
),
513 Make_Attribute_Reference
(Loc
,
515 New_Occurrence_Of
(Standard_Character
, Loc
),
516 Attribute_Name
=> Name_Pos
,
517 Expressions
=> New_List
(
518 Make_Indexed_Component
(Loc
,
519 Prefix
=> New_Occurrence_Of
(S_Id
, Loc
),
520 Expressions
=> New_List
(
523 Make_Indexed_Component
(Loc
,
525 New_Occurrence_Of
(EPos
, Loc
),
526 Expressions
=> New_List
(
527 New_Occurrence_Of
(K
, Loc
))),
529 New_Occurrence_Of
(F
, Loc
))))))));
531 -- Generate A := (A + Natural (T1 (K) * J)) mod N;
533 Append_To
(Loop_Stmts
,
534 Make_Assignment_Statement
(Loc
,
535 Name
=> New_Occurrence_Of
(A
, Loc
),
540 Left_Opnd
=> New_Occurrence_Of
(A
, Loc
),
542 Make_Op_Multiply
(Loc
,
544 Convert_To
(Standard_Natural
,
545 Make_Indexed_Component
(Loc
,
547 New_Occurrence_Of
(ET1
, Loc
),
548 Expressions
=> New_List
(
549 New_Occurrence_Of
(K
, Loc
)))),
550 Right_Opnd
=> New_Occurrence_Of
(J
, Loc
))),
551 Right_Opnd
=> Make_Integer_Literal
(Loc
, Int
(L1
)))));
553 -- Generate B := (B + Natural (T2 (K) * J)) mod N;
555 Append_To
(Loop_Stmts
,
556 Make_Assignment_Statement
(Loc
,
557 Name
=> New_Occurrence_Of
(B
, Loc
),
562 Left_Opnd
=> New_Occurrence_Of
(B
, Loc
),
564 Make_Op_Multiply
(Loc
,
566 Convert_To
(Standard_Natural
,
567 Make_Indexed_Component
(Loc
,
569 New_Occurrence_Of
(ET2
, Loc
),
570 Expressions
=> New_List
(
571 New_Occurrence_Of
(K
, Loc
)))),
572 Right_Opnd
=> New_Occurrence_Of
(J
, Loc
))),
573 Right_Opnd
=> Make_Integer_Literal
(Loc
, Int
(L1
)))));
577 Body_Stmts
:= New_List
(
578 Make_Implicit_Loop_Statement
(N
,
580 Make_Iteration_Scheme
(Loc
,
581 Loop_Parameter_Specification
=>
582 Make_Loop_Parameter_Specification
(Loc
,
583 Defining_Identifier
=> K
,
584 Discrete_Subtype_Definition
=>
585 Make_Attribute_Reference
(Loc
,
587 New_Occurrence_Of
(EPos
, Loc
),
588 Attribute_Name
=> Name_Range
))),
589 Statements
=> Loop_Stmts
));
591 -- Generate return (Natural (G (A)) + Natural (G (B))) mod M;
593 Append_To
(Body_Stmts
,
594 Make_Simple_Return_Statement
(Loc
,
600 Convert_To
(Standard_Natural
,
601 Make_Indexed_Component
(Loc
,
603 New_Occurrence_Of
(EG
, Loc
),
604 Expressions
=> New_List
(
605 New_Occurrence_Of
(A
, Loc
)))),
607 Convert_To
(Standard_Natural
,
608 Make_Indexed_Component
(Loc
,
610 New_Occurrence_Of
(EG
, Loc
),
611 Expressions
=> New_List
(
612 New_Occurrence_Of
(B
, Loc
))))),
613 Right_Opnd
=> Make_Integer_Literal
(Loc
, Nlit
))));
615 -- Generate final body
618 Make_Subprogram_Body
(Loc
,
619 Specification
=> H_Sp
,
620 Declarations
=> Body_Decls
,
621 Handled_Statement_Sequence
=>
622 Make_Handled_Sequence_Of_Statements
(Loc
, Body_Stmts
)));
625 -- If we chose not to or did not manage to compute the hash function,
626 -- we need to build a dummy function always returning Natural'Last
627 -- because other units reference it if they use the Value attribute.
629 elsif In_Main_Unit
then
631 Body_Stmts
: List_Id
;
634 -- Generate return Natural'Last
636 Body_Stmts
:= New_List
(
637 Make_Simple_Return_Statement
(Loc
,
639 Make_Attribute_Reference
(Loc
,
641 New_Occurrence_Of
(Standard_Natural
, Loc
),
642 Attribute_Name
=> Name_Last
)));
647 Make_Subprogram_Body
(Loc
,
648 Specification
=> H_Sp
,
649 Declarations
=> Empty_List
,
650 Handled_Statement_Sequence
=>
651 Make_Handled_Sequence_Of_Statements
(Loc
, Body_Stmts
)));
654 -- For the other units, just declare the function
658 Make_Subprogram_Declaration
(Loc
, Specification
=> H_Sp
));
662 Set_Lit_Hash
(E
, Empty
);
666 System
.Perfect_Hash_Generators
.Finalize
;
669 Insert_Actions
(N
, Act
, Suppress
=> All_Checks
);
671 -- This is where we check that our budget of serial numbers has been
672 -- entirely spent, see the declaration of Serial_Number_Budget above.
674 if Nlit
> Threshold
then
675 Synchronize_Serial_Number
(S_N
+ Serial_Number_Budget
);
678 -- Reset the scalar storage order to the saved value
680 Opt
.Default_SSO
:= Saved_SSO
;
681 end Build_Enumeration_Image_Tables
;
683 ----------------------------
684 -- Expand_Image_Attribute --
685 ----------------------------
687 -- For all cases other than user-defined enumeration types, the scheme
688 -- is as follows. First we insert the following code:
690 -- Snn : String (1 .. rt'Width);
692 -- Image_xx (tv, Snn, Pnn [,pm]);
694 -- and then Expr is replaced by Snn (1 .. Pnn)
696 -- In the above expansion:
698 -- rt is the root type of the expression
699 -- tv is the expression with the value, usually a type conversion
700 -- pm is an extra parameter present in some cases
702 -- The following table shows tv, xx, and (if used) pm for the various
703 -- possible types of the argument:
705 -- For types whose root type is Character
707 -- tv = Character (Expr)
709 -- For types whose root type is Boolean
711 -- tv = Boolean (Expr)
713 -- For signed integer types
714 -- xx = [Long_Long_[Long_]]Integer
715 -- tv = [Long_Long_[Long_]]Integer (Expr)
718 -- xx = [Long_Long_[Long_]]Unsigned
719 -- tv = System.Unsigned_Types.[Long_Long_[Long_]]Unsigned (Expr)
721 -- For types whose root type is Wide_Character
722 -- xx = Wide_Character
723 -- tv = Wide_Character (Expr)
724 -- pm = Boolean, true if Ada 2005 mode, False otherwise
726 -- For types whose root type is Wide_Wide_Character
727 -- xx = Wide_Wide_Character
728 -- tv = Wide_Wide_Character (Expr)
730 -- For floating-point types
731 -- xx = Floating_Point
732 -- tv = [Long_[Long_]]Float (Expr)
733 -- pm = typ'Digits (typ = subtype of expression)
735 -- For decimal fixed-point types
736 -- xx = Decimal{32,64,128}
737 -- tv = Integer_{32,64,128} (Expr)? [convert with no scaling]
738 -- pm = typ'Scale (typ = subtype of expression)
740 -- For the most common ordinary fixed-point types
741 -- xx = Fixed{32,64,128}
742 -- tv = Integer_{32,64,128} (Expr) [convert with no scaling]
743 -- pm = numerator of typ'Small (typ = subtype of expression)
744 -- denominator of typ'Small
745 -- (Integer_{32,64,128} x typ'Small)'Fore
748 -- For other ordinary fixed-point types
750 -- tv = Long_Float (Expr)
751 -- pm = typ'Aft (typ = subtype of expression)
753 -- For enumeration types other than those declared in package Standard
754 -- or System, Snn, Pnn, are expanded as above, but the call looks like:
756 -- Image_Enumeration_NN (rt'Pos (X), Snn, Pnn, typS, typI'Address)
758 -- where rt is the root type of the expression, and typS and typI are
759 -- the entities constructed as described in the spec for the procedure
760 -- Build_Enumeration_Image_Tables and NN is 32/16/8 depending on the
761 -- element type of Lit_Indexes. The rewriting of the expression to
762 -- Snn (1 .. Pnn) then occurs as in the other cases. A special case is
763 -- when pragma Discard_Names applies, in which case we replace expr by:
765 -- (rt'Pos (expr))'Img
767 -- So that the result is a space followed by the decimal value for the
768 -- position of the enumeration value in the enumeration type.
770 procedure Expand_Image_Attribute
(N
: Node_Id
) is
771 Loc
: constant Source_Ptr
:= Sloc
(N
);
772 Exprs
: constant List_Id
:= Expressions
(N
);
773 Expr
: constant Node_Id
:= Relocate_Node
(First
(Exprs
));
774 Pref
: constant Node_Id
:= Prefix
(N
);
776 procedure Expand_Standard_Boolean_Image
;
777 -- Expand attribute 'Image in Standard.Boolean, avoiding string copy
779 procedure Expand_User_Defined_Enumeration_Image
(Typ
: Entity_Id
);
780 -- Expand attribute 'Image in user-defined enumeration types, avoiding
783 -----------------------------------
784 -- Expand_Standard_Boolean_Image --
785 -----------------------------------
787 procedure Expand_Standard_Boolean_Image
is
788 Ins_List
: constant List_Id
:= New_List
;
789 S1_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
790 T_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
791 F_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'F');
792 V_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'V');
795 -- We use a single 5-character string subtype throughout so that the
796 -- subtype of the string if-expression is constrained and, therefore,
797 -- does not force the creation of a temporary during analysis.
800 -- subtype S1 is String (1 .. 5);
803 Make_Subtype_Declaration
(Loc
,
804 Defining_Identifier
=> S1_Id
,
805 Subtype_Indication
=>
806 Make_Subtype_Indication
(Loc
,
808 New_Occurrence_Of
(Standard_String
, Loc
),
810 Make_Index_Or_Discriminant_Constraint
(Loc
,
811 Constraints
=> New_List
(
813 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
814 High_Bound
=> Make_Integer_Literal
(Loc
, 5)))))));
817 -- T : constant String (1 .. 5) := "TRUE ";
820 Store_String_Chars
("TRUE ");
823 Make_Object_Declaration
(Loc
,
824 Defining_Identifier
=> T_Id
,
826 New_Occurrence_Of
(S1_Id
, Loc
),
827 Constant_Present
=> True,
828 Expression
=> Make_String_Literal
(Loc
, End_String
)));
831 -- F : constant String (1 .. 5) := "FALSE";
834 Store_String_Chars
("FALSE");
837 Make_Object_Declaration
(Loc
,
838 Defining_Identifier
=> F_Id
,
840 New_Occurrence_Of
(S1_Id
, Loc
),
841 Constant_Present
=> True,
842 Expression
=> Make_String_Literal
(Loc
, End_String
)));
845 -- V : String (1 .. 5) renames (if Expr then T else F);
848 Make_Object_Renaming_Declaration
(Loc
,
849 Defining_Identifier
=> V_Id
,
851 New_Occurrence_Of
(S1_Id
, Loc
),
853 Make_If_Expression
(Loc
,
854 Expressions
=> New_List
(
855 Duplicate_Subexpr
(Expr
),
856 New_Occurrence_Of
(T_Id
, Loc
),
857 New_Occurrence_Of
(F_Id
, Loc
)))));
859 -- Insert all the above declarations before N. We suppress checks
860 -- because everything is in range at this stage.
862 Insert_Actions
(N
, Ins_List
, Suppress
=> All_Checks
);
864 -- Final step is to rewrite the expression as a slice:
865 -- V (1 .. (if Expr then 4 else 5)) and analyze, again with no
866 -- checks, since we are sure that everything is OK.
870 Prefix
=> New_Occurrence_Of
(V_Id
, Loc
),
873 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
875 Make_If_Expression
(Loc
,
876 Expressions
=> New_List
(
877 Duplicate_Subexpr
(Expr
),
878 Make_Integer_Literal
(Loc
, 4),
879 Make_Integer_Literal
(Loc
, 5))))));
881 Analyze_And_Resolve
(N
, Standard_String
, Suppress
=> All_Checks
);
882 end Expand_Standard_Boolean_Image
;
884 -------------------------------------------
885 -- Expand_User_Defined_Enumeration_Image --
886 -------------------------------------------
888 procedure Expand_User_Defined_Enumeration_Image
(Typ
: Entity_Id
) is
889 Ins_List
: constant List_Id
:= New_List
;
890 P1_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
891 P2_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
892 P3_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
893 P4_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
894 S1_Id
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
897 -- Apply a validity check, since it is a bit drastic to get a
898 -- completely junk image value for an invalid value.
900 if not Expr_Known_Valid
(Expr
) then
901 Insert_Valid_Check
(Expr
);
905 -- P1 : constant Natural := Typ'Pos (Typ?(Expr));
908 Make_Object_Declaration
(Loc
,
909 Defining_Identifier
=> P1_Id
,
911 New_Occurrence_Of
(Standard_Natural
, Loc
),
912 Constant_Present
=> True,
914 Convert_To
(Standard_Natural
,
915 Make_Attribute_Reference
(Loc
,
916 Attribute_Name
=> Name_Pos
,
917 Prefix
=> New_Occurrence_Of
(Typ
, Loc
),
918 Expressions
=> New_List
(OK_Convert_To
(Typ
, Expr
))))));
920 -- Compute the index of the string start, generating:
921 -- P2 : constant Natural := call_put_enumN (P1);
924 Make_Object_Declaration
(Loc
,
925 Defining_Identifier
=> P2_Id
,
927 New_Occurrence_Of
(Standard_Natural
, Loc
),
928 Constant_Present
=> True,
930 Convert_To
(Standard_Natural
,
931 Make_Indexed_Component
(Loc
,
933 New_Occurrence_Of
(Lit_Indexes
(Typ
), Loc
),
935 New_List
(New_Occurrence_Of
(P1_Id
, Loc
))))));
937 -- Compute the index of the next value, generating:
938 -- P3 : constant Natural := call_put_enumN (P1 + 1);
941 Add_Node
: constant Node_Id
:= New_Op_Node
(N_Op_Add
, Loc
);
944 Set_Left_Opnd
(Add_Node
, New_Occurrence_Of
(P1_Id
, Loc
));
945 Set_Right_Opnd
(Add_Node
, Make_Integer_Literal
(Loc
, 1));
948 Make_Object_Declaration
(Loc
,
949 Defining_Identifier
=> P3_Id
,
951 New_Occurrence_Of
(Standard_Natural
, Loc
),
952 Constant_Present
=> True,
954 Convert_To
(Standard_Natural
,
955 Make_Indexed_Component
(Loc
,
957 New_Occurrence_Of
(Lit_Indexes
(Typ
), Loc
),
959 New_List
(Add_Node
)))));
963 -- P4 : String renames call_put_enumS (P2 .. P3 - 1);
966 Sub_Node
: constant Node_Id
:= New_Op_Node
(N_Op_Subtract
, Loc
);
969 Set_Left_Opnd
(Sub_Node
, New_Occurrence_Of
(P3_Id
, Loc
));
970 Set_Right_Opnd
(Sub_Node
, Make_Integer_Literal
(Loc
, 1));
973 Make_Object_Renaming_Declaration
(Loc
,
974 Defining_Identifier
=> P4_Id
,
976 New_Occurrence_Of
(Standard_String
, Loc
),
980 New_Occurrence_Of
(Lit_Strings
(Typ
), Loc
),
983 Low_Bound
=> New_Occurrence_Of
(P2_Id
, Loc
),
984 High_Bound
=> Sub_Node
))));
988 -- subtype S1 is String (1 .. P3 - P2);
991 HB
: constant Node_Id
:= New_Op_Node
(N_Op_Subtract
, Loc
);
994 Set_Left_Opnd
(HB
, New_Occurrence_Of
(P3_Id
, Loc
));
995 Set_Right_Opnd
(HB
, New_Occurrence_Of
(P2_Id
, Loc
));
998 Make_Subtype_Declaration
(Loc
,
999 Defining_Identifier
=> S1_Id
,
1000 Subtype_Indication
=>
1001 Make_Subtype_Indication
(Loc
,
1003 New_Occurrence_Of
(Standard_String
, Loc
),
1005 Make_Index_Or_Discriminant_Constraint
(Loc
,
1006 Constraints
=> New_List
(
1008 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
1009 High_Bound
=> HB
))))));
1012 -- Insert all the above declarations before N. We suppress checks
1013 -- because everything is in range at this stage.
1015 Insert_Actions
(N
, Ins_List
, Suppress
=> All_Checks
);
1018 Unchecked_Convert_To
(S1_Id
, New_Occurrence_Of
(P4_Id
, Loc
)));
1020 Analyze_And_Resolve
(N
, Standard_String
);
1021 end Expand_User_Defined_Enumeration_Image
;
1025 Enum_Case
: Boolean;
1027 Proc_Ent
: Entity_Id
;
1030 Tent
: Entity_Id
:= Empty
;
1034 -- List of arguments for run-time procedure call
1037 -- List of actions to be inserted
1039 Snn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
1040 Pnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
1042 -- Start of processing for Expand_Image_Attribute
1045 if Is_Object_Image
(Pref
) then
1046 Rewrite_Object_Image
(N
, Pref
, Name_Image
, Standard_String
);
1050 -- If Image should be transformed using Put_Image, then do so. See
1051 -- Exp_Put_Image for details.
1053 if Exp_Put_Image
.Image_Should_Call_Put_Image
(N
) then
1054 Rewrite
(N
, Exp_Put_Image
.Build_Image_Call
(N
));
1055 Analyze_And_Resolve
(N
, Standard_String
, Suppress
=> All_Checks
);
1059 Ptyp
:= Underlying_Type
(Entity
(Pref
));
1061 -- Ada 2022 allows 'Image on private types, so fetch the underlying
1062 -- type to obtain the structure of the type. We use the base type,
1063 -- not the root type for discrete types, to handle properly derived
1064 -- types, but we use the root type for enumeration types, because the
1065 -- literal map is attached to the root. Should be inherited ???
1067 if Is_Real_Type
(Ptyp
) or else Is_Enumeration_Type
(Ptyp
) then
1068 Rtyp
:= Underlying_Type
(Root_Type
(Ptyp
));
1070 Rtyp
:= Underlying_Type
(Base_Type
(Ptyp
));
1073 -- Set Imid (RE_Id of procedure to call), and Tent, target for the
1074 -- type conversion of the first argument for all possibilities.
1078 if Rtyp
= Standard_Boolean
then
1079 -- Use inline expansion if the -gnatd_x switch is not passed to the
1080 -- compiler. Otherwise expand into a call to the runtime.
1082 if not Debug_Flag_Underscore_X
then
1083 Expand_Standard_Boolean_Image
;
1087 Imid
:= RE_Image_Boolean
;
1091 -- For standard character, we have to select the version which handles
1092 -- soft hyphen correctly, based on the version of Ada in use (this is
1093 -- ugly, but we have no choice).
1095 elsif Rtyp
= Standard_Character
then
1096 if Ada_Version
< Ada_2005
then
1097 Imid
:= RE_Image_Character
;
1099 Imid
:= RE_Image_Character_05
;
1104 elsif Rtyp
= Standard_Wide_Character
then
1105 Imid
:= RE_Image_Wide_Character
;
1108 elsif Rtyp
= Standard_Wide_Wide_Character
then
1109 Imid
:= RE_Image_Wide_Wide_Character
;
1112 elsif Is_Signed_Integer_Type
(Rtyp
) then
1113 if Esize
(Rtyp
) <= Standard_Integer_Size
then
1114 Imid
:= RE_Image_Integer
;
1115 Tent
:= Standard_Integer
;
1116 elsif Esize
(Rtyp
) <= Standard_Long_Long_Integer_Size
then
1117 Imid
:= RE_Image_Long_Long_Integer
;
1118 Tent
:= Standard_Long_Long_Integer
;
1120 Imid
:= RE_Image_Long_Long_Long_Integer
;
1121 Tent
:= Standard_Long_Long_Long_Integer
;
1124 elsif Is_Modular_Integer_Type
(Rtyp
) then
1125 if Modulus
(Rtyp
) <= Modulus
(RTE
(RE_Unsigned
)) then
1126 Imid
:= RE_Image_Unsigned
;
1127 Tent
:= RTE
(RE_Unsigned
);
1128 elsif Modulus
(Rtyp
) <= Modulus
(RTE
(RE_Long_Long_Unsigned
)) then
1129 Imid
:= RE_Image_Long_Long_Unsigned
;
1130 Tent
:= RTE
(RE_Long_Long_Unsigned
);
1132 Imid
:= RE_Image_Long_Long_Long_Unsigned
;
1133 Tent
:= RTE
(RE_Long_Long_Long_Unsigned
);
1136 elsif Is_Decimal_Fixed_Point_Type
(Rtyp
) then
1137 if Esize
(Rtyp
) <= 32 then
1138 Imid
:= RE_Image_Decimal32
;
1139 Tent
:= RTE
(RE_Integer_32
);
1140 elsif Esize
(Rtyp
) <= 64 then
1141 Imid
:= RE_Image_Decimal64
;
1142 Tent
:= RTE
(RE_Integer_64
);
1144 Imid
:= RE_Image_Decimal128
;
1145 Tent
:= RTE
(RE_Integer_128
);
1148 elsif Is_Ordinary_Fixed_Point_Type
(Rtyp
) then
1150 Num
: constant Uint
:= Norm_Num
(Small_Value
(Rtyp
));
1151 Den
: constant Uint
:= Norm_Den
(Small_Value
(Rtyp
));
1152 Max
: constant Uint
:= UI_Max
(Num
, Den
);
1153 Min
: constant Uint
:= UI_Min
(Num
, Den
);
1154 Siz
: constant Uint
:= Esize
(Rtyp
);
1157 -- Note that we do not use sharp bounds to speed things up
1160 and then Max
<= Uint_2
** 31
1161 and then (Min
= Uint_1
1162 or else (Num
< Den
and then Den
<= Uint_2
** 27)
1163 or else (Den
< Num
and then Num
<= Uint_2
** 25))
1165 Imid
:= RE_Image_Fixed32
;
1166 Tent
:= RTE
(RE_Integer_32
);
1168 and then Max
<= Uint_2
** 63
1169 and then (Min
= Uint_1
1170 or else (Num
< Den
and then Den
<= Uint_2
** 59)
1171 or else (Den
< Num
and then Num
<= Uint_2
** 53))
1173 Imid
:= RE_Image_Fixed64
;
1174 Tent
:= RTE
(RE_Integer_64
);
1175 elsif System_Max_Integer_Size
= 128
1176 and then Max
<= Uint_2
** 127
1177 and then (Min
= Uint_1
1178 or else (Num
< Den
and then Den
<= Uint_2
** 123)
1179 or else (Den
< Num
and then Num
<= Uint_2
** 122))
1181 Imid
:= RE_Image_Fixed128
;
1182 Tent
:= RTE
(RE_Integer_128
);
1184 Imid
:= RE_Image_Fixed
;
1185 Tent
:= Standard_Long_Float
;
1189 elsif Is_Floating_Point_Type
(Rtyp
) then
1190 -- Short_Float and Float are the same type for GNAT
1192 if Rtyp
= Standard_Short_Float
or else Rtyp
= Standard_Float
then
1193 Imid
:= RE_Image_Float
;
1194 Tent
:= Standard_Float
;
1196 elsif Rtyp
= Standard_Long_Float
then
1197 Imid
:= RE_Image_Long_Float
;
1198 Tent
:= Standard_Long_Float
;
1201 Imid
:= RE_Image_Long_Long_Float
;
1202 Tent
:= Standard_Long_Long_Float
;
1205 -- Only other possibility is user-defined enumeration type
1208 pragma Assert
(Is_Enumeration_Type
(Rtyp
));
1210 if Discard_Names
(First_Subtype
(Ptyp
))
1211 or else No
(Lit_Strings
(Rtyp
))
1213 -- When pragma Discard_Names applies to the first subtype, build
1214 -- (Long_Long_Integer (Pref'Pos (Expr)))'Img. The conversion is
1215 -- there to avoid applying 'Img directly in Universal_Integer,
1216 -- which can be a very large type. See also the handling of 'Val.
1219 Make_Attribute_Reference
(Loc
,
1221 Convert_To
(Standard_Long_Long_Integer
,
1222 Make_Attribute_Reference
(Loc
,
1224 Attribute_Name
=> Name_Pos
,
1225 Expressions
=> New_List
(Expr
))),
1228 Analyze_And_Resolve
(N
, Standard_String
);
1231 -- Use inline expansion if the -gnatd_x switch is not passed to the
1232 -- compiler. Otherwise expand into a call to the runtime.
1234 elsif not Debug_Flag_Underscore_X
then
1235 Expand_User_Defined_Enumeration_Image
(Rtyp
);
1239 Ttyp
:= Component_Type
(Etype
(Lit_Indexes
(Rtyp
)));
1241 if Ttyp
= Standard_Integer_8
then
1242 Imid
:= RE_Image_Enumeration_8
;
1244 elsif Ttyp
= Standard_Integer_16
then
1245 Imid
:= RE_Image_Enumeration_16
;
1248 Imid
:= RE_Image_Enumeration_32
;
1251 -- Apply a validity check, since it is a bit drastic to get a
1252 -- completely junk image value for an invalid value.
1254 if not Expr_Known_Valid
(Expr
) then
1255 Insert_Valid_Check
(Expr
);
1262 -- Build first argument for call
1265 Arg_List
:= New_List
(
1266 Make_Attribute_Reference
(Loc
,
1267 Attribute_Name
=> Name_Pos
,
1268 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
1269 Expressions
=> New_List
(Expr
)));
1271 -- AI12-0020: Ada 2022 allows 'Image for all types, including private
1272 -- types. If the full type is not a fixed-point type, then it is enough
1273 -- to set the Conversion_OK flag. However, that would not work for
1274 -- fixed-point types, because that flag changes the run-time semantics
1275 -- of fixed-point type conversions; therefore, we must first convert to
1276 -- Rtyp, and then to Tent.
1283 if Is_Private_Type
(Etype
(Expr
)) then
1284 if Is_Fixed_Point_Type
(Rtyp
) then
1285 Conv
:= Convert_To
(Tent
, OK_Convert_To
(Rtyp
, Expr
));
1287 Conv
:= OK_Convert_To
(Tent
, Expr
);
1290 Conv
:= Convert_To
(Tent
, Expr
);
1293 Arg_List
:= New_List
(Conv
);
1297 -- Build declarations of Snn and Pnn to be inserted
1299 Ins_List
:= New_List
(
1301 -- Snn : String (1 .. typ'Width);
1303 Make_Object_Declaration
(Loc
,
1304 Defining_Identifier
=> Snn
,
1305 Object_Definition
=>
1306 Make_Subtype_Indication
(Loc
,
1307 Subtype_Mark
=> New_Occurrence_Of
(Standard_String
, Loc
),
1309 Make_Index_Or_Discriminant_Constraint
(Loc
,
1310 Constraints
=> New_List
(
1312 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
1314 Make_Attribute_Reference
(Loc
,
1315 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
),
1316 Attribute_Name
=> Name_Width
)))))),
1320 Make_Object_Declaration
(Loc
,
1321 Defining_Identifier
=> Pnn
,
1322 Object_Definition
=> New_Occurrence_Of
(Standard_Natural
, Loc
)));
1324 -- Append Snn, Pnn arguments
1326 Append_To
(Arg_List
, New_Occurrence_Of
(Snn
, Loc
));
1327 Append_To
(Arg_List
, New_Occurrence_Of
(Pnn
, Loc
));
1329 -- Get entity of procedure to call
1331 Proc_Ent
:= RTE
(Imid
);
1333 -- If the procedure entity is empty, that means we have a case in
1334 -- no run time mode where the operation is not allowed, and an
1335 -- appropriate diagnostic has already been issued.
1337 if No
(Proc_Ent
) then
1341 -- Otherwise complete preparation of arguments for run-time call
1343 -- Add extra arguments for Enumeration case
1346 Append_To
(Arg_List
, New_Occurrence_Of
(Lit_Strings
(Rtyp
), Loc
));
1347 Append_To
(Arg_List
,
1348 Make_Attribute_Reference
(Loc
,
1349 Prefix
=> New_Occurrence_Of
(Lit_Indexes
(Rtyp
), Loc
),
1350 Attribute_Name
=> Name_Address
));
1352 -- For floating-point types, append Digits argument
1354 elsif Is_Floating_Point_Type
(Rtyp
) then
1355 Append_To
(Arg_List
,
1356 Make_Attribute_Reference
(Loc
,
1357 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
1358 Attribute_Name
=> Name_Digits
));
1360 -- For decimal, append Scale and also set to do literal conversion
1362 elsif Is_Decimal_Fixed_Point_Type
(Rtyp
) then
1363 Set_Conversion_OK
(First
(Arg_List
));
1365 Append_To
(Arg_List
, Make_Integer_Literal
(Loc
, Scale_Value
(Ptyp
)));
1367 -- For ordinary fixed-point types, append Num, Den, Fore, Aft parameters
1368 -- and also set to do literal conversion.
1370 elsif Is_Ordinary_Fixed_Point_Type
(Rtyp
) then
1371 if Imid
/= RE_Image_Fixed
then
1372 Set_Conversion_OK
(First
(Arg_List
));
1374 Append_To
(Arg_List
,
1375 Make_Integer_Literal
(Loc
, -Norm_Num
(Small_Value
(Ptyp
))));
1377 Append_To
(Arg_List
,
1378 Make_Integer_Literal
(Loc
, -Norm_Den
(Small_Value
(Ptyp
))));
1380 -- We want to compute the Fore value for the fixed point type
1381 -- whose mantissa type is Tent and whose small is typ'Small.
1384 T
: Ureal
:= Uint_2
** (Esize
(Tent
) - 1) * Small_Value
(Ptyp
);
1388 while T
>= Ureal_10
loop
1393 Append_To
(Arg_List
,
1394 Make_Integer_Literal
(Loc
, UI_From_Int
(F
)));
1398 Append_To
(Arg_List
, Make_Integer_Literal
(Loc
, Aft_Value
(Ptyp
)));
1400 -- For Wide_Character, append Ada 2005 indication
1402 elsif Rtyp
= Standard_Wide_Character
then
1403 Append_To
(Arg_List
,
1405 (Boolean_Literals
(Ada_Version
>= Ada_2005
), Loc
));
1408 -- Now append the procedure call to the insert list
1410 Append_To
(Ins_List
,
1411 Make_Procedure_Call_Statement
(Loc
,
1412 Name
=> New_Occurrence_Of
(Proc_Ent
, Loc
),
1413 Parameter_Associations
=> Arg_List
));
1415 -- Insert declarations of Snn, Pnn, and the procedure call. We suppress
1416 -- checks because we are sure that everything is in range at this stage.
1418 Insert_Actions
(N
, Ins_List
, Suppress
=> All_Checks
);
1420 -- Final step is to rewrite the expression as a slice and analyze,
1421 -- again with no checks, since we are sure that everything is OK.
1425 Prefix
=> New_Occurrence_Of
(Snn
, Loc
),
1428 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
1429 High_Bound
=> New_Occurrence_Of
(Pnn
, Loc
))));
1431 Analyze_And_Resolve
(N
, Standard_String
, Suppress
=> All_Checks
);
1432 end Expand_Image_Attribute
;
1434 ----------------------------------
1435 -- Expand_Valid_Value_Attribute --
1436 ----------------------------------
1438 procedure Expand_Valid_Value_Attribute
(N
: Node_Id
) is
1439 Loc
: constant Source_Ptr
:= Sloc
(N
);
1440 Btyp
: constant Entity_Id
:= Base_Type
(Entity
(Prefix
(N
)));
1441 Rtyp
: constant Entity_Id
:= Root_Type
(Btyp
);
1442 pragma Assert
(Is_Enumeration_Type
(Rtyp
));
1444 Args
: constant List_Id
:= Expressions
(N
);
1451 -- Valid_Value_Enumeration_NN
1452 -- (typS, typN'Address, typH'Unrestricted_Access, Num, X)
1454 Ttyp
:= Component_Type
(Etype
(Lit_Indexes
(Rtyp
)));
1456 if Ttyp
= Standard_Integer_8
then
1457 Func
:= RE_Valid_Value_Enumeration_8
;
1458 elsif Ttyp
= Standard_Integer_16
then
1459 Func
:= RE_Valid_Value_Enumeration_16
;
1461 Func
:= RE_Valid_Value_Enumeration_32
;
1465 Make_Attribute_Reference
(Loc
,
1466 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
),
1467 Attribute_Name
=> Name_Pos
,
1468 Expressions
=> New_List
(
1469 Make_Attribute_Reference
(Loc
,
1470 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
),
1471 Attribute_Name
=> Name_Last
))));
1473 if Present
(Lit_Hash
(Rtyp
)) then
1475 Make_Attribute_Reference
(Loc
,
1476 Prefix
=> New_Occurrence_Of
(Lit_Hash
(Rtyp
), Loc
),
1477 Attribute_Name
=> Name_Unrestricted_Access
));
1479 Prepend_To
(Args
, Make_Null
(Loc
));
1483 Make_Attribute_Reference
(Loc
,
1484 Prefix
=> New_Occurrence_Of
(Lit_Indexes
(Rtyp
), Loc
),
1485 Attribute_Name
=> Name_Address
));
1488 New_Occurrence_Of
(Lit_Strings
(Rtyp
), Loc
));
1491 Make_Function_Call
(Loc
,
1493 New_Occurrence_Of
(RTE
(Func
), Loc
),
1494 Parameter_Associations
=> Args
));
1496 Analyze_And_Resolve
(N
, Standard_Boolean
);
1497 end Expand_Valid_Value_Attribute
;
1499 ----------------------------
1500 -- Expand_Value_Attribute --
1501 ----------------------------
1503 -- For scalar types derived from Boolean, Character and integer types
1504 -- in package Standard, typ'Value (X) expands into:
1506 -- btyp (Value_xx (X))
1508 -- where btyp is the base type of the prefix
1510 -- For types whose root type is Character
1513 -- For types whose root type is Wide_Character
1514 -- xx = Wide_Character
1516 -- For types whose root type is Wide_Wide_Character
1517 -- xx = Wide_Wide_Character
1519 -- For types whose root type is Boolean
1522 -- For signed integer types
1523 -- xx = [Long_Long_[Long_]]Integer
1525 -- For modular types
1526 -- xx = [Long_Long_[Long_]]Unsigned
1528 -- For floating-point types
1529 -- xx = [Long_[Long_]]Float
1531 -- For decimal fixed-point types, typ'Value (X) expands into
1533 -- btyp?(Value_Decimal{32,64,128} (X, typ'Scale));
1535 -- For the most common ordinary fixed-point types, it expands into
1537 -- btyp?(Value_Fixed{32,64,128} (X, numerator of S, denominator of S));
1538 -- where S = typ'Small
1540 -- For other ordinary fixed-point types, it expands into
1542 -- btyp (Value_Long_Float (X))
1544 -- For Wide_[Wide_]Character types, typ'Value (X) expands into
1546 -- btyp (Value_xx (X, EM))
1548 -- where btyp is the base type of the prefix, and EM is the encoding method
1550 -- For enumeration types other than those derived from types Boolean,
1551 -- Character, Wide_[Wide_]Character in Standard, typ'Value (X) expands to:
1554 -- (Value_Enumeration_NN
1555 -- (typS, typN'Address, typH'Unrestricted_Access, Num, X))
1557 -- where typS, typN and typH are the Lit_Strings, Lit_Indexes and Lit_Hash
1558 -- entities from T's root type entity, and Num is Enum'Pos (Enum'Last).
1559 -- The Value_Enumeration_NN function will search the tables looking for
1560 -- X and return the position number in the table if found which is
1561 -- used to provide the result of 'Value (using Enum'Val). If the
1562 -- value is not found Constraint_Error is raised. The suffix _NN
1563 -- depends on the element type of typN.
1565 procedure Expand_Value_Attribute
(N
: Node_Id
) is
1566 Loc
: constant Source_Ptr
:= Sloc
(N
);
1567 Btyp
: constant Entity_Id
:= Etype
(N
);
1568 pragma Assert
(Is_Base_Type
(Btyp
));
1569 pragma Assert
(Btyp
= Base_Type
(Entity
(Prefix
(N
))));
1570 Rtyp
: constant Entity_Id
:= Root_Type
(Btyp
);
1572 Args
: constant List_Id
:= Expressions
(N
);
1577 -- Fall through for all cases except user-defined enumeration type
1578 -- and decimal types, with Vid set to the Id of the entity for the
1579 -- Value routine and Args set to the list of parameters for the call.
1581 if Rtyp
= Standard_Boolean
then
1582 Vid
:= RE_Value_Boolean
;
1584 elsif Rtyp
= Standard_Character
then
1585 Vid
:= RE_Value_Character
;
1587 elsif Rtyp
= Standard_Wide_Character
then
1588 Vid
:= RE_Value_Wide_Character
;
1591 Make_Integer_Literal
(Loc
,
1592 Intval
=> Int
(Wide_Character_Encoding_Method
)));
1594 elsif Rtyp
= Standard_Wide_Wide_Character
then
1595 Vid
:= RE_Value_Wide_Wide_Character
;
1598 Make_Integer_Literal
(Loc
,
1599 Intval
=> Int
(Wide_Character_Encoding_Method
)));
1601 elsif Is_Signed_Integer_Type
(Rtyp
) then
1602 if Esize
(Rtyp
) <= Standard_Integer_Size
then
1603 Vid
:= RE_Value_Integer
;
1604 elsif Esize
(Rtyp
) <= Standard_Long_Long_Integer_Size
then
1605 Vid
:= RE_Value_Long_Long_Integer
;
1607 Vid
:= RE_Value_Long_Long_Long_Integer
;
1610 elsif Is_Modular_Integer_Type
(Rtyp
) then
1611 if Modulus
(Rtyp
) <= Modulus
(RTE
(RE_Unsigned
)) then
1612 Vid
:= RE_Value_Unsigned
;
1613 elsif Modulus
(Rtyp
) <= Modulus
(RTE
(RE_Long_Long_Unsigned
)) then
1614 Vid
:= RE_Value_Long_Long_Unsigned
;
1616 Vid
:= RE_Value_Long_Long_Long_Unsigned
;
1619 elsif Is_Decimal_Fixed_Point_Type
(Rtyp
) then
1620 if Esize
(Rtyp
) <= 32 and then abs (Scale_Value
(Rtyp
)) <= 9 then
1621 Vid
:= RE_Value_Decimal32
;
1622 elsif Esize
(Rtyp
) <= 64 and then abs (Scale_Value
(Rtyp
)) <= 18 then
1623 Vid
:= RE_Value_Decimal64
;
1625 Vid
:= RE_Value_Decimal128
;
1628 Append_To
(Args
, Make_Integer_Literal
(Loc
, Scale_Value
(Rtyp
)));
1631 OK_Convert_To
(Btyp
,
1632 Make_Function_Call
(Loc
,
1633 Name
=> New_Occurrence_Of
(RTE
(Vid
), Loc
),
1634 Parameter_Associations
=> Args
)));
1636 Set_Etype
(N
, Btyp
);
1637 Analyze_And_Resolve
(N
, Btyp
);
1640 elsif Is_Ordinary_Fixed_Point_Type
(Rtyp
) then
1642 Num
: constant Uint
:= Norm_Num
(Small_Value
(Rtyp
));
1643 Den
: constant Uint
:= Norm_Den
(Small_Value
(Rtyp
));
1644 Max
: constant Uint
:= UI_Max
(Num
, Den
);
1645 Min
: constant Uint
:= UI_Min
(Num
, Den
);
1646 Siz
: constant Uint
:= Esize
(Rtyp
);
1650 and then Max
<= Uint_2
** 31
1651 and then (Min
= Uint_1
or else Max
<= Uint_2
** 27)
1653 Vid
:= RE_Value_Fixed32
;
1655 and then Max
<= Uint_2
** 63
1656 and then (Min
= Uint_1
or else Max
<= Uint_2
** 59)
1658 Vid
:= RE_Value_Fixed64
;
1659 elsif System_Max_Integer_Size
= 128
1660 and then Max
<= Uint_2
** 127
1661 and then (Min
= Uint_1
or else Max
<= Uint_2
** 123)
1663 Vid
:= RE_Value_Fixed128
;
1665 Vid
:= RE_Value_Long_Float
;
1668 if Vid
/= RE_Value_Long_Float
then
1670 Make_Integer_Literal
(Loc
, -Norm_Num
(Small_Value
(Rtyp
))));
1673 Make_Integer_Literal
(Loc
, -Norm_Den
(Small_Value
(Rtyp
))));
1676 OK_Convert_To
(Btyp
,
1677 Make_Function_Call
(Loc
,
1678 Name
=> New_Occurrence_Of
(RTE
(Vid
), Loc
),
1679 Parameter_Associations
=> Args
)));
1681 Set_Etype
(N
, Btyp
);
1682 Analyze_And_Resolve
(N
, Btyp
);
1687 elsif Is_Floating_Point_Type
(Rtyp
) then
1688 -- Short_Float and Float are the same type for GNAT
1690 if Rtyp
= Standard_Short_Float
or else Rtyp
= Standard_Float
then
1691 Vid
:= RE_Value_Float
;
1693 elsif Rtyp
= Standard_Long_Float
then
1694 Vid
:= RE_Value_Long_Float
;
1697 Vid
:= RE_Value_Long_Long_Float
;
1700 -- Only other possibility is user-defined enumeration type
1703 pragma Assert
(Is_Enumeration_Type
(Rtyp
));
1705 -- Case of pragma Discard_Names, transform the Value
1706 -- attribute to Btyp'Val (Long_Long_Integer'Value (Args))
1708 if Discard_Names
(First_Subtype
(Btyp
))
1709 or else No
(Lit_Strings
(Rtyp
))
1712 Make_Attribute_Reference
(Loc
,
1713 Prefix
=> New_Occurrence_Of
(Btyp
, Loc
),
1714 Attribute_Name
=> Name_Val
,
1715 Expressions
=> New_List
(
1716 Make_Attribute_Reference
(Loc
,
1718 New_Occurrence_Of
(Standard_Long_Long_Integer
, Loc
),
1719 Attribute_Name
=> Name_Value
,
1720 Expressions
=> Args
))));
1722 Analyze_And_Resolve
(N
, Btyp
);
1724 -- Normal case where we have enumeration tables, build
1727 -- (Value_Enumeration_NN
1728 -- (typS, typN'Address, typH'Unrestricted_Access, Num, X))
1731 Ttyp
:= Component_Type
(Etype
(Lit_Indexes
(Rtyp
)));
1733 if Ttyp
= Standard_Integer_8
then
1734 Vid
:= RE_Value_Enumeration_8
;
1735 elsif Ttyp
= Standard_Integer_16
then
1736 Vid
:= RE_Value_Enumeration_16
;
1738 Vid
:= RE_Value_Enumeration_32
;
1742 Make_Attribute_Reference
(Loc
,
1743 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
),
1744 Attribute_Name
=> Name_Pos
,
1745 Expressions
=> New_List
(
1746 Make_Attribute_Reference
(Loc
,
1747 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
),
1748 Attribute_Name
=> Name_Last
))));
1750 if Present
(Lit_Hash
(Rtyp
)) then
1752 Make_Attribute_Reference
(Loc
,
1753 Prefix
=> New_Occurrence_Of
(Lit_Hash
(Rtyp
), Loc
),
1754 Attribute_Name
=> Name_Unrestricted_Access
));
1756 Prepend_To
(Args
, Make_Null
(Loc
));
1760 Make_Attribute_Reference
(Loc
,
1761 Prefix
=> New_Occurrence_Of
(Lit_Indexes
(Rtyp
), Loc
),
1762 Attribute_Name
=> Name_Address
));
1765 New_Occurrence_Of
(Lit_Strings
(Rtyp
), Loc
));
1768 Make_Attribute_Reference
(Loc
,
1769 Prefix
=> New_Occurrence_Of
(Btyp
, Loc
),
1770 Attribute_Name
=> Name_Val
,
1771 Expressions
=> New_List
(
1772 Make_Function_Call
(Loc
,
1774 New_Occurrence_Of
(RTE
(Vid
), Loc
),
1775 Parameter_Associations
=> Args
))));
1777 Analyze_And_Resolve
(N
, Btyp
);
1783 -- Compiling package Ada.Tags under No_Run_Time_Mode we disable the
1784 -- expansion of the attribute into the function call statement to avoid
1785 -- generating spurious errors caused by the use of Integer_Address'Value
1786 -- in our implementation of Ada.Tags.Internal_Tag.
1789 and then Is_RTE
(Rtyp
, RE_Integer_Address
)
1790 and then RTU_Loaded
(Ada_Tags
)
1791 and then Cunit_Entity
(Current_Sem_Unit
)
1792 = Body_Entity
(RTU_Entity
(Ada_Tags
))
1795 Unchecked_Convert_To
(Rtyp
,
1796 Make_Integer_Literal
(Loc
, Uint_0
)));
1801 Make_Function_Call
(Loc
,
1802 Name
=> New_Occurrence_Of
(RTE
(Vid
), Loc
),
1803 Parameter_Associations
=> Args
)));
1806 Analyze_And_Resolve
(N
, Btyp
);
1807 end Expand_Value_Attribute
;
1809 ---------------------------------
1810 -- Expand_Wide_Image_Attribute --
1811 ---------------------------------
1813 -- We expand typ'Wide_Image (X) as follows. First we insert this code:
1815 -- Rnn : Wide_String (1 .. rt'Wide_Width);
1817 -- String_To_Wide_String
1818 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
1820 -- where rt is the root type of the prefix type
1822 -- Now we replace the Wide_Image reference by
1826 -- This works in all cases because String_To_Wide_String converts any
1827 -- wide character escape sequences resulting from the Image call to the
1828 -- proper Wide_Character equivalent
1830 -- not quite right for typ = Wide_Character ???
1832 procedure Expand_Wide_Image_Attribute
(N
: Node_Id
) is
1833 Loc
: constant Source_Ptr
:= Sloc
(N
);
1834 Pref
: constant Entity_Id
:= Prefix
(N
);
1835 Rnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
1836 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
1840 if Is_Object_Image
(Pref
) then
1841 Rewrite_Object_Image
(N
, Pref
, Name_Wide_Image
, Standard_Wide_String
);
1845 Rtyp
:= Root_Type
(Entity
(Pref
));
1847 Insert_Actions
(N
, New_List
(
1849 -- Rnn : Wide_String (1 .. base_typ'Width);
1851 Make_Object_Declaration
(Loc
,
1852 Defining_Identifier
=> Rnn
,
1853 Object_Definition
=>
1854 Make_Subtype_Indication
(Loc
,
1856 New_Occurrence_Of
(Standard_Wide_String
, Loc
),
1858 Make_Index_Or_Discriminant_Constraint
(Loc
,
1859 Constraints
=> New_List
(
1861 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
1863 Make_Attribute_Reference
(Loc
,
1864 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
),
1865 Attribute_Name
=> Name_Wide_Width
)))))),
1869 Make_Object_Declaration
(Loc
,
1870 Defining_Identifier
=> Lnn
,
1871 Object_Definition
=> New_Occurrence_Of
(Standard_Natural
, Loc
)),
1873 -- String_To_Wide_String
1874 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
1876 Make_Procedure_Call_Statement
(Loc
,
1878 New_Occurrence_Of
(RTE
(RE_String_To_Wide_String
), Loc
),
1880 Parameter_Associations
=> New_List
(
1881 Make_Attribute_Reference
(Loc
,
1882 Prefix
=> Prefix
(N
),
1883 Attribute_Name
=> Name_Image
,
1884 Expressions
=> Expressions
(N
)),
1885 New_Occurrence_Of
(Rnn
, Loc
),
1886 New_Occurrence_Of
(Lnn
, Loc
),
1887 Make_Integer_Literal
(Loc
,
1888 Intval
=> Int
(Wide_Character_Encoding_Method
))))),
1890 -- Suppress checks because we know everything is properly in range
1892 Suppress
=> All_Checks
);
1894 -- Final step is to rewrite the expression as a slice and analyze,
1895 -- again with no checks, since we are sure that everything is OK.
1899 Prefix
=> New_Occurrence_Of
(Rnn
, Loc
),
1902 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
1903 High_Bound
=> New_Occurrence_Of
(Lnn
, Loc
))));
1905 Analyze_And_Resolve
(N
, Standard_Wide_String
, Suppress
=> All_Checks
);
1906 end Expand_Wide_Image_Attribute
;
1908 --------------------------------------
1909 -- Expand_Wide_Wide_Image_Attribute --
1910 --------------------------------------
1912 -- We expand typ'Wide_Wide_Image (X) as follows. First we insert this code:
1914 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
1916 -- String_To_Wide_Wide_String
1917 -- (typ'Image (Expr), Rnn, Lnn, Wide_Character_Encoding_Method);
1919 -- where rt is the root type of the prefix type
1921 -- Now we replace the Wide_Wide_Image reference by
1925 -- This works in all cases because String_To_Wide_Wide_String converts any
1926 -- wide character escape sequences resulting from the Image call to the
1927 -- proper Wide_Wide_Character equivalent
1929 -- not quite right for typ = Wide_Wide_Character ???
1931 procedure Expand_Wide_Wide_Image_Attribute
(N
: Node_Id
) is
1932 Loc
: constant Source_Ptr
:= Sloc
(N
);
1933 Pref
: constant Entity_Id
:= Prefix
(N
);
1934 Rnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'S');
1935 Lnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'P');
1939 if Is_Object_Image
(Pref
) then
1940 Rewrite_Object_Image
1941 (N
, Pref
, Name_Wide_Wide_Image
, Standard_Wide_Wide_String
);
1945 Rtyp
:= Root_Type
(Entity
(Pref
));
1947 Insert_Actions
(N
, New_List
(
1949 -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width);
1951 Make_Object_Declaration
(Loc
,
1952 Defining_Identifier
=> Rnn
,
1953 Object_Definition
=>
1954 Make_Subtype_Indication
(Loc
,
1956 New_Occurrence_Of
(Standard_Wide_Wide_String
, Loc
),
1958 Make_Index_Or_Discriminant_Constraint
(Loc
,
1959 Constraints
=> New_List
(
1961 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
1963 Make_Attribute_Reference
(Loc
,
1964 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
),
1965 Attribute_Name
=> Name_Wide_Wide_Width
)))))),
1969 Make_Object_Declaration
(Loc
,
1970 Defining_Identifier
=> Lnn
,
1971 Object_Definition
=> New_Occurrence_Of
(Standard_Natural
, Loc
)),
1973 -- String_To_Wide_Wide_String
1974 -- (typ'Image (X), Rnn, Lnn, Wide_Character_Encoding_Method);
1976 Make_Procedure_Call_Statement
(Loc
,
1978 New_Occurrence_Of
(RTE
(RE_String_To_Wide_Wide_String
), Loc
),
1980 Parameter_Associations
=> New_List
(
1981 Make_Attribute_Reference
(Loc
,
1982 Prefix
=> Prefix
(N
),
1983 Attribute_Name
=> Name_Image
,
1984 Expressions
=> Expressions
(N
)),
1985 New_Occurrence_Of
(Rnn
, Loc
),
1986 New_Occurrence_Of
(Lnn
, Loc
),
1987 Make_Integer_Literal
(Loc
,
1988 Intval
=> Int
(Wide_Character_Encoding_Method
))))),
1990 -- Suppress checks because we know everything is properly in range
1992 Suppress
=> All_Checks
);
1994 -- Final step is to rewrite the expression as a slice and analyze,
1995 -- again with no checks, since we are sure that everything is OK.
1999 Prefix
=> New_Occurrence_Of
(Rnn
, Loc
),
2002 Low_Bound
=> Make_Integer_Literal
(Loc
, 1),
2003 High_Bound
=> New_Occurrence_Of
(Lnn
, Loc
))));
2006 (N
, Standard_Wide_Wide_String
, Suppress
=> All_Checks
);
2007 end Expand_Wide_Wide_Image_Attribute
;
2009 ----------------------------
2010 -- Expand_Width_Attribute --
2011 ----------------------------
2013 -- The processing here also handles the case of Wide_[Wide_]Width. With the
2014 -- exceptions noted, the processing is identical
2016 -- For scalar types derived from Boolean, character and integer types
2017 -- in package Standard. Note that the Width attribute is computed at
2018 -- compile time for all cases except those involving non-static sub-
2019 -- types. For such subtypes, typ'[Wide_[Wide_]]Width expands into:
2021 -- Result_Type (xx (yy (Ptyp'First), yy (Ptyp'Last)))
2025 -- For types whose root type is Character
2026 -- xx = Width_Character
2029 -- For types whose root type is Wide_Character
2030 -- xx = Wide_Width_Character
2033 -- For types whose root type is Wide_Wide_Character
2034 -- xx = Wide_Wide_Width_Character
2037 -- For types whose root type is Boolean
2038 -- xx = Width_Boolean
2041 -- For signed integer types
2042 -- xx = Width_[Long_Long_[Long_]]Integer
2043 -- yy = [Long_Long_[Long_]]Integer
2045 -- For modular integer types
2046 -- xx = Width_[Long_Long_[Long_]]Unsigned
2047 -- yy = [Long_Long_[Long_]]Unsigned
2049 -- For types derived from Wide_Character, typ'Width expands into
2051 -- Result_Type (Width_Wide_Character (
2052 -- Wide_Character (typ'First),
2053 -- Wide_Character (typ'Last),
2055 -- and typ'Wide_Width expands into:
2057 -- Result_Type (Wide_Width_Wide_Character (
2058 -- Wide_Character (typ'First),
2059 -- Wide_Character (typ'Last));
2061 -- and typ'Wide_Wide_Width expands into
2063 -- Result_Type (Wide_Wide_Width_Wide_Character (
2064 -- Wide_Character (typ'First),
2065 -- Wide_Character (typ'Last));
2067 -- For types derived from Wide_Wide_Character, typ'Width expands into
2069 -- Result_Type (Width_Wide_Wide_Character (
2070 -- Wide_Wide_Character (typ'First),
2071 -- Wide_Wide_Character (typ'Last),
2073 -- and typ'Wide_Width expands into:
2075 -- Result_Type (Wide_Width_Wide_Wide_Character (
2076 -- Wide_Wide_Character (typ'First),
2077 -- Wide_Wide_Character (typ'Last));
2079 -- and typ'Wide_Wide_Width expands into
2081 -- Result_Type (Wide_Wide_Width_Wide_Wide_Char (
2082 -- Wide_Wide_Character (typ'First),
2083 -- Wide_Wide_Character (typ'Last));
2085 -- For fixed point types, typ'Width and typ'Wide_[Wide_]Width expand into
2087 -- if Ptyp'First > Ptyp'Last then 0 else Ptyp'Fore + 1 + Ptyp'Aft end if
2089 -- and for floating point types, they expand into
2091 -- if Ptyp'First > Ptyp'Last then 0 else btyp'Width end if
2093 -- where btyp is the base type. This looks recursive but it isn't
2094 -- because the base type is always static, and hence the expression
2095 -- in the else is reduced to an integer literal.
2097 -- For user-defined enumeration types, typ'Width expands into
2099 -- Result_Type (Width_Enumeration_NN
2102 -- typ'Pos (typ'First),
2103 -- typ'Pos (Typ'Last)));
2105 -- and typ'Wide_Width expands into:
2107 -- Result_Type (Wide_Width_Enumeration_NN
2110 -- typ'Pos (typ'First),
2111 -- typ'Pos (Typ'Last))
2112 -- Wide_Character_Encoding_Method);
2114 -- and typ'Wide_Wide_Width expands into:
2116 -- Result_Type (Wide_Wide_Width_Enumeration_NN
2119 -- typ'Pos (typ'First),
2120 -- typ'Pos (Typ'Last))
2121 -- Wide_Character_Encoding_Method);
2123 -- where typS and typI are the enumeration image strings and indexes
2124 -- table, as described in Build_Enumeration_Image_Tables. NN is 8/16/32
2125 -- for depending on the element type for typI.
2127 -- Finally if Discard_Names is in effect for an enumeration type, then
2128 -- a special if expression is built that yields the space needed for the
2129 -- decimal representation of the largest pos value in the subtype. See
2130 -- code below for details.
2132 procedure Expand_Width_Attribute
(N
: Node_Id
; Attr
: Atype
:= Normal
) is
2133 Loc
: constant Source_Ptr
:= Sloc
(N
);
2134 Typ
: constant Entity_Id
:= Etype
(N
);
2135 Pref
: constant Node_Id
:= Prefix
(N
);
2136 Ptyp
: constant Entity_Id
:= Etype
(Pref
);
2137 Rtyp
: constant Entity_Id
:= Root_Type
(Ptyp
);
2144 -- Types derived from Standard.Boolean
2146 if Rtyp
= Standard_Boolean
then
2147 XX
:= RE_Width_Boolean
;
2150 -- Types derived from Standard.Character
2152 elsif Rtyp
= Standard_Character
then
2154 when Normal
=> XX
:= RE_Width_Character
;
2155 when Wide
=> XX
:= RE_Wide_Width_Character
;
2156 when Wide_Wide
=> XX
:= RE_Wide_Wide_Width_Character
;
2161 -- Types derived from Standard.Wide_Character
2163 elsif Rtyp
= Standard_Wide_Character
then
2165 when Normal
=> XX
:= RE_Width_Wide_Character
;
2166 when Wide
=> XX
:= RE_Wide_Width_Wide_Character
;
2167 when Wide_Wide
=> XX
:= RE_Wide_Wide_Width_Wide_Character
;
2172 -- Types derived from Standard.Wide_Wide_Character
2174 elsif Rtyp
= Standard_Wide_Wide_Character
then
2176 when Normal
=> XX
:= RE_Width_Wide_Wide_Character
;
2177 when Wide
=> XX
:= RE_Wide_Width_Wide_Wide_Character
;
2178 when Wide_Wide
=> XX
:= RE_Wide_Wide_Width_Wide_Wide_Char
;
2183 -- Signed integer types
2185 elsif Is_Signed_Integer_Type
(Rtyp
) then
2186 if Esize
(Rtyp
) <= Standard_Integer_Size
then
2187 XX
:= RE_Width_Integer
;
2188 YY
:= Standard_Integer
;
2189 elsif Esize
(Rtyp
) <= Standard_Long_Long_Integer_Size
then
2190 XX
:= RE_Width_Long_Long_Integer
;
2191 YY
:= Standard_Long_Long_Integer
;
2193 XX
:= RE_Width_Long_Long_Long_Integer
;
2194 YY
:= Standard_Long_Long_Long_Integer
;
2197 -- Modular integer types
2199 elsif Is_Modular_Integer_Type
(Rtyp
) then
2200 if Modulus
(Rtyp
) <= Modulus
(RTE
(RE_Unsigned
)) then
2201 XX
:= RE_Width_Unsigned
;
2202 YY
:= RTE
(RE_Unsigned
);
2203 elsif Modulus
(Rtyp
) <= Modulus
(RTE
(RE_Long_Long_Unsigned
)) then
2204 XX
:= RE_Width_Long_Long_Unsigned
;
2205 YY
:= RTE
(RE_Long_Long_Unsigned
);
2207 XX
:= RE_Width_Long_Long_Long_Unsigned
;
2208 YY
:= RTE
(RE_Long_Long_Long_Unsigned
);
2211 -- Fixed point types
2213 elsif Is_Fixed_Point_Type
(Rtyp
) then
2215 Make_If_Expression
(Loc
,
2216 Expressions
=> New_List
(
2220 Make_Attribute_Reference
(Loc
,
2221 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2222 Attribute_Name
=> Name_First
),
2225 Make_Attribute_Reference
(Loc
,
2226 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2227 Attribute_Name
=> Name_Last
)),
2229 Make_Integer_Literal
(Loc
, 0),
2232 Make_Attribute_Reference
(Loc
,
2233 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2234 Attribute_Name
=> Name_Fore
),
2237 Make_Integer_Literal
(Loc
, 1),
2238 Make_Integer_Literal
(Loc
, Aft_Value
(Ptyp
)))))));
2240 Analyze_And_Resolve
(N
, Typ
);
2243 -- Floating point types
2245 elsif Is_Floating_Point_Type
(Rtyp
) then
2247 Make_If_Expression
(Loc
,
2248 Expressions
=> New_List
(
2252 Make_Attribute_Reference
(Loc
,
2253 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2254 Attribute_Name
=> Name_First
),
2257 Make_Attribute_Reference
(Loc
,
2258 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2259 Attribute_Name
=> Name_Last
)),
2261 Make_Integer_Literal
(Loc
, 0),
2263 Make_Attribute_Reference
(Loc
,
2264 Prefix
=> New_Occurrence_Of
(Base_Type
(Ptyp
), Loc
),
2265 Attribute_Name
=> Name_Width
))));
2267 Analyze_And_Resolve
(N
, Typ
);
2270 -- User-defined enumeration types
2273 pragma Assert
(Is_Enumeration_Type
(Rtyp
));
2275 -- Whenever pragma Discard_Names is in effect, the value we need
2276 -- is the value needed to accommodate the largest integer pos value
2277 -- in the range of the subtype + 1 for the space at the start. We
2280 -- Tnn : constant Integer := Rtyp'Pos (Ptyp'Last)
2282 -- and replace the expression by
2284 -- (if Ptyp'Range_Length = 0 then 0
2285 -- else (if Tnn < 10 then 2
2286 -- else (if Tnn < 100 then 3
2290 -- where n is equal to Rtyp'Pos (Ptyp'Last) + 1
2292 -- Note: The above processing is in accordance with the intent of
2293 -- the RM, which is that Width should be related to the impl-defined
2294 -- behavior of Image. It is not clear what this means if Image is
2295 -- not defined (as in the configurable run-time case for GNAT) and
2296 -- gives an error at compile time.
2298 -- We choose in this case to just go ahead and implement Width the
2299 -- same way, returning what Image would have returned if it has been
2300 -- available in the configurable run-time library.
2302 if Discard_Names
(Rtyp
) then
2304 Tnn
: constant Entity_Id
:= Make_Temporary
(Loc
, 'T');
2312 Make_Object_Declaration
(Loc
,
2313 Defining_Identifier
=> Tnn
,
2314 Constant_Present
=> True,
2315 Object_Definition
=>
2316 New_Occurrence_Of
(Standard_Integer
, Loc
),
2318 Make_Attribute_Reference
(Loc
,
2319 Prefix
=> New_Occurrence_Of
(Rtyp
, Loc
),
2320 Attribute_Name
=> Name_Pos
,
2321 Expressions
=> New_List
(
2323 Make_Attribute_Reference
(Loc
,
2324 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2325 Attribute_Name
=> Name_Last
))))));
2327 -- OK, now we need to build the if expression. First get the
2328 -- value of M, the largest possible value needed.
2331 (Enumeration_Pos
(Entity
(Type_High_Bound
(Rtyp
))));
2342 Cexpr
:= Make_Integer_Literal
(Loc
, K
);
2344 -- Wrap in inner if's until counted down to 2
2351 Make_If_Expression
(Loc
,
2352 Expressions
=> New_List
(
2354 Left_Opnd
=> New_Occurrence_Of
(Tnn
, Loc
),
2355 Right_Opnd
=> Make_Integer_Literal
(Loc
, M
)),
2356 Make_Integer_Literal
(Loc
, K
),
2360 -- Add initial comparison for null range and we are done, so
2361 -- rewrite the attribute occurrence with this expression.
2365 Make_If_Expression
(Loc
,
2366 Expressions
=> New_List
(
2369 Make_Attribute_Reference
(Loc
,
2370 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2371 Attribute_Name
=> Name_Range_Length
),
2372 Right_Opnd
=> Make_Integer_Literal
(Loc
, 0)),
2373 Make_Integer_Literal
(Loc
, 0),
2376 Analyze_And_Resolve
(N
, Typ
);
2381 -- Normal case, not Discard_Names
2383 Ttyp
:= Component_Type
(Etype
(Lit_Indexes
(Rtyp
)));
2387 if Ttyp
= Standard_Integer_8
then
2388 XX
:= RE_Width_Enumeration_8
;
2389 elsif Ttyp
= Standard_Integer_16
then
2390 XX
:= RE_Width_Enumeration_16
;
2392 XX
:= RE_Width_Enumeration_32
;
2396 if Ttyp
= Standard_Integer_8
then
2397 XX
:= RE_Wide_Width_Enumeration_8
;
2398 elsif Ttyp
= Standard_Integer_16
then
2399 XX
:= RE_Wide_Width_Enumeration_16
;
2401 XX
:= RE_Wide_Width_Enumeration_32
;
2405 if Ttyp
= Standard_Integer_8
then
2406 XX
:= RE_Wide_Wide_Width_Enumeration_8
;
2407 elsif Ttyp
= Standard_Integer_16
then
2408 XX
:= RE_Wide_Wide_Width_Enumeration_16
;
2410 XX
:= RE_Wide_Wide_Width_Enumeration_32
;
2416 New_Occurrence_Of
(Lit_Strings
(Rtyp
), Loc
),
2418 Make_Attribute_Reference
(Loc
,
2419 Prefix
=> New_Occurrence_Of
(Lit_Indexes
(Rtyp
), Loc
),
2420 Attribute_Name
=> Name_Address
),
2422 Make_Attribute_Reference
(Loc
,
2423 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2424 Attribute_Name
=> Name_Pos
,
2426 Expressions
=> New_List
(
2427 Make_Attribute_Reference
(Loc
,
2428 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2429 Attribute_Name
=> Name_First
))),
2431 Make_Attribute_Reference
(Loc
,
2432 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2433 Attribute_Name
=> Name_Pos
,
2435 Expressions
=> New_List
(
2436 Make_Attribute_Reference
(Loc
,
2437 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2438 Attribute_Name
=> Name_Last
))));
2442 Make_Function_Call
(Loc
,
2443 Name
=> New_Occurrence_Of
(RTE
(XX
), Loc
),
2444 Parameter_Associations
=> Arglist
)));
2446 Analyze_And_Resolve
(N
, Typ
);
2450 -- If we fall through XX and YY are set
2452 Arglist
:= New_List
(
2454 Make_Attribute_Reference
(Loc
,
2455 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2456 Attribute_Name
=> Name_First
)),
2459 Make_Attribute_Reference
(Loc
,
2460 Prefix
=> New_Occurrence_Of
(Ptyp
, Loc
),
2461 Attribute_Name
=> Name_Last
)));
2465 Make_Function_Call
(Loc
,
2466 Name
=> New_Occurrence_Of
(RTE
(XX
), Loc
),
2467 Parameter_Associations
=> Arglist
)));
2469 Analyze_And_Resolve
(N
, Typ
);
2470 end Expand_Width_Attribute
;
2472 --------------------------
2473 -- Rewrite_Object_Image --
2474 --------------------------
2476 procedure Rewrite_Object_Image
2479 Attr_Name
: Name_Id
;
2480 Str_Typ
: Entity_Id
)
2484 Make_Attribute_Reference
(Sloc
(N
),
2485 Prefix
=> New_Occurrence_Of
(Etype
(Pref
), Sloc
(N
)),
2486 Attribute_Name
=> Attr_Name
,
2487 Expressions
=> New_List
(Relocate_Node
(Pref
))));
2489 Analyze_And_Resolve
(N
, Str_Typ
);
2490 end Rewrite_Object_Image
;