1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
11 -- Copyright (C) 1999-2001 Free Software Foundation, Inc. --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- Extensive contributions were provided by Ada Core Technologies Inc. --
34 ------------------------------------------------------------------------------
36 with Alloc
; use Alloc
;
37 with Atree
; use Atree
;
38 with Casing
; use Casing
;
39 with Debug
; use Debug
;
40 with Einfo
; use Einfo
;
42 with Namet
; use Namet
;
44 with Output
; use Output
;
45 with Sinfo
; use Sinfo
;
46 with Sinput
; use Sinput
;
47 with Table
; use Table
;
48 with Uname
; use Uname
;
49 with Urealp
; use Urealp
;
51 package body Repinfo
is
54 -- Value for Storage_Unit, we do not want to get this from TTypes, since
55 -- this introduces problematic dependencies in ASIS, and in any case this
56 -- value is assumed to be 8 for the implementation of the DDA.
57 -- This is wrong for AAMP???
59 ---------------------------------------
60 -- Representation of gcc Expressions --
61 ---------------------------------------
63 -- This table is used only if Frontend_Layout_On_Target is False,
64 -- so that gigi lays out dynamic size/offset fields using encoded
67 -- A table internal to this unit is used to hold the values of
68 -- back annotated expressions. This table is written out by -gnatt
69 -- and read back in for ASIS processing.
71 -- Node values are stored as Uint values which are the negative of
72 -- the node index in this table. Constants appear as non-negative
75 type Exp_Node
is record
77 Op1
: Node_Ref_Or_Val
;
78 Op2
: Node_Ref_Or_Val
;
79 Op3
: Node_Ref_Or_Val
;
82 package Rep_Table
is new Table
.Table
(
83 Table_Component_Type
=> Exp_Node
,
84 Table_Index_Type
=> Nat
,
86 Table_Initial
=> Alloc
.Rep_Table_Initial
,
87 Table_Increment
=> Alloc
.Rep_Table_Increment
,
88 Table_Name
=> "BE_Rep_Table");
90 --------------------------------------------------------------
91 -- Representation of Front-End Dynamic Size/Offset Entities --
92 --------------------------------------------------------------
94 package Dynamic_SO_Entity_Table
is new Table
.Table
(
95 Table_Component_Type
=> Entity_Id
,
96 Table_Index_Type
=> Nat
,
98 Table_Initial
=> Alloc
.Rep_Table_Initial
,
99 Table_Increment
=> Alloc
.Rep_Table_Increment
,
100 Table_Name
=> "FE_Rep_Table");
102 -----------------------
103 -- Local Subprograms --
104 -----------------------
106 Unit_Casing
: Casing_Type
;
107 -- Identifier casing for current unit
109 procedure Spaces
(N
: Natural);
110 -- Output given number of spaces
112 function Back_End_Layout
return Boolean;
113 -- Test for layout mode, True = back end, False = front end. This
114 -- function is used rather than checking the configuration parameter
115 -- because we do not want Repinfo to depend on Targparm (for ASIS)
117 procedure List_Entities
(Ent
: Entity_Id
);
118 -- This procedure lists the entities associated with the entity E,
119 -- starting with the First_Entity and using the Next_Entity link.
120 -- If a nested package is found, entities within the package are
121 -- recursively processed.
123 procedure List_Name
(Ent
: Entity_Id
);
124 -- List name of entity Ent in appropriate case. The name is listed with
125 -- full qualification up to but not including the compilation unit name.
127 procedure List_Array_Info
(Ent
: Entity_Id
);
128 -- List representation info for array type Ent
130 procedure List_Object_Info
(Ent
: Entity_Id
);
131 -- List representation info for object Ent
133 procedure List_Record_Info
(Ent
: Entity_Id
);
134 -- List representation info for record type Ent
136 procedure List_Type_Info
(Ent
: Entity_Id
);
137 -- List type info for type Ent
139 function Rep_Not_Constant
(Val
: Node_Ref_Or_Val
) return Boolean;
140 -- Returns True if Val represents a variable value, and False if it
141 -- represents a value that is fixed at compile time.
143 procedure Write_Val
(Val
: Node_Ref_Or_Val
; Paren
: Boolean := False);
144 -- Given a representation value, write it out. No_Uint values or values
145 -- dependent on discriminants are written as two question marks. If the
146 -- flag Paren is set, then the output is surrounded in parentheses if
147 -- it is other than a simple value.
149 ---------------------
150 -- Back_End_Layout --
151 ---------------------
153 function Back_End_Layout
return Boolean is
155 -- We have back end layout if the back end has made any entries in
156 -- the table of GCC expressions, otherwise we have front end layout.
158 return Rep_Table
.Last
> 0;
161 ------------------------
162 -- Create_Discrim_Ref --
163 ------------------------
165 function Create_Discrim_Ref
169 N
: constant Uint
:= Discriminant_Number
(Discr
);
173 Rep_Table
.Increment_Last
;
175 Rep_Table
.Table
(T
).Expr
:= Discrim_Val
;
176 Rep_Table
.Table
(T
).Op1
:= N
;
177 Rep_Table
.Table
(T
).Op2
:= No_Uint
;
178 Rep_Table
.Table
(T
).Op3
:= No_Uint
;
179 return UI_From_Int
(-T
);
180 end Create_Discrim_Ref
;
182 ---------------------------
183 -- Create_Dynamic_SO_Ref --
184 ---------------------------
186 function Create_Dynamic_SO_Ref
188 return Dynamic_SO_Ref
193 Dynamic_SO_Entity_Table
.Increment_Last
;
194 T
:= Dynamic_SO_Entity_Table
.Last
;
195 Dynamic_SO_Entity_Table
.Table
(T
) := E
;
196 return UI_From_Int
(-T
);
197 end Create_Dynamic_SO_Ref
;
205 Op1
: Node_Ref_Or_Val
;
206 Op2
: Node_Ref_Or_Val
:= No_Uint
;
207 Op3
: Node_Ref_Or_Val
:= No_Uint
)
213 Rep_Table
.Increment_Last
;
215 Rep_Table
.Table
(T
).Expr
:= Expr
;
216 Rep_Table
.Table
(T
).Op1
:= Op1
;
217 Rep_Table
.Table
(T
).Op2
:= Op2
;
218 Rep_Table
.Table
(T
).Op3
:= Op3
;
220 return UI_From_Int
(-T
);
223 ---------------------------
224 -- Get_Dynamic_SO_Entity --
225 ---------------------------
227 function Get_Dynamic_SO_Entity
232 return Dynamic_SO_Entity_Table
.Table
(-UI_To_Int
(U
));
233 end Get_Dynamic_SO_Entity
;
235 -----------------------
236 -- Is_Dynamic_SO_Ref --
237 -----------------------
239 function Is_Dynamic_SO_Ref
(U
: SO_Ref
) return Boolean is
242 end Is_Dynamic_SO_Ref
;
244 ----------------------
245 -- Is_Static_SO_Ref --
246 ----------------------
248 function Is_Static_SO_Ref
(U
: SO_Ref
) return Boolean is
251 end Is_Static_SO_Ref
;
257 procedure lgx
(U
: Node_Ref_Or_Val
) is
259 List_GCC_Expression
(U
);
263 ----------------------
264 -- List_Array_Info --
265 ----------------------
267 procedure List_Array_Info
(Ent
: Entity_Id
) is
269 List_Type_Info
(Ent
);
273 Write_Str
("'Component_Size use ");
274 Write_Val
(Component_Size
(Ent
));
282 procedure List_Entities
(Ent
: Entity_Id
) is
286 if Present
(Ent
) then
287 E
:= First_Entity
(Ent
);
288 while Present
(E
) loop
289 if Comes_From_Source
(E
) or else Debug_Flag_AA
then
291 if Is_Record_Type
(E
) then
292 List_Record_Info
(E
);
294 elsif Is_Array_Type
(E
) then
297 elsif List_Representation_Info
>= 2 then
302 elsif Ekind
(E
) = E_Variable
304 Ekind
(E
) = E_Constant
306 Ekind
(E
) = E_Loop_Parameter
310 List_Object_Info
(E
);
314 -- Recurse over nested package, but not if they are
315 -- package renamings (in particular renamings of the
316 -- enclosing package, as for some Java bindings and
317 -- for generic instances).
319 if (Ekind
(E
) = E_Package
320 and then No
(Renamed_Object
(E
)))
322 Ekind
(E
) = E_Protected_Type
324 Ekind
(E
) = E_Task_Type
326 Ekind
(E
) = E_Subprogram_Body
328 Ekind
(E
) = E_Package_Body
330 Ekind
(E
) = E_Task_Body
332 Ekind
(E
) = E_Protected_Body
338 E
:= Next_Entity
(E
);
343 -------------------------
344 -- List_GCC_Expression --
345 -------------------------
347 procedure List_GCC_Expression
(U
: Node_Ref_Or_Val
) is
349 procedure P
(Val
: Node_Ref_Or_Val
);
350 -- Internal recursive procedure to print expression
352 procedure P
(Val
: Node_Ref_Or_Val
) is
355 UI_Write
(Val
, Decimal
);
359 Node
: Exp_Node
renames Rep_Table
.Table
(-UI_To_Int
(Val
));
361 procedure Binop
(S
: String);
362 -- Output text for binary operator with S being operator name
364 procedure Binop
(S
: String) is
373 -- Start of processing for P
380 Write_Str
(" then ");
382 Write_Str
(" else ");
395 when Trunc_Div_Expr
=>
398 when Ceil_Div_Expr
=>
401 when Floor_Div_Expr
=>
404 when Trunc_Mod_Expr
=>
407 when Floor_Mod_Expr
=>
410 when Ceil_Mod_Expr
=>
413 when Exact_Div_Expr
=>
430 when Truth_Andif_Expr
=>
433 when Truth_Orif_Expr
=>
436 when Truth_And_Expr
=>
439 when Truth_Or_Expr
=>
442 when Truth_Xor_Expr
=>
445 when Truth_Not_Expr
=>
476 -- Start of processing for List_GCC_Expression
484 end List_GCC_Expression
;
490 procedure List_Name
(Ent
: Entity_Id
) is
492 if not Is_Compilation_Unit
(Scope
(Ent
)) then
493 List_Name
(Scope
(Ent
));
497 Get_Unqualified_Decoded_Name_String
(Chars
(Ent
));
498 Set_Casing
(Unit_Casing
);
499 Write_Str
(Name_Buffer
(1 .. Name_Len
));
502 ---------------------
503 -- List_Object_Info --
504 ---------------------
506 procedure List_Object_Info
(Ent
: Entity_Id
) is
510 if Known_Esize
(Ent
) then
513 Write_Str
("'Size use ");
514 Write_Val
(Esize
(Ent
));
518 if Known_Alignment
(Ent
) then
521 Write_Str
("'Alignment use ");
522 Write_Val
(Alignment
(Ent
));
525 end List_Object_Info
;
527 ----------------------
528 -- List_Record_Info --
529 ----------------------
531 procedure List_Record_Info
(Ent
: Entity_Id
) is
537 Max_Name_Length
: Natural;
538 Max_Suni_Length
: Natural;
541 List_Type_Info
(Ent
);
545 Write_Line
(" use record");
547 -- First loop finds out max line length and max starting position
548 -- length, for the purpose of lining things up nicely.
550 Max_Name_Length
:= 0;
551 Max_Suni_Length
:= 0;
553 Comp
:= First_Entity
(Ent
);
554 while Present
(Comp
) loop
555 if Ekind
(Comp
) = E_Component
556 or else Ekind
(Comp
) = E_Discriminant
558 Get_Decoded_Name_String
(Chars
(Comp
));
559 Max_Name_Length
:= Natural'Max (Max_Name_Length
, Name_Len
);
561 Cfbit
:= Component_Bit_Offset
(Comp
);
563 if Rep_Not_Constant
(Cfbit
) then
564 UI_Image_Length
:= 2;
567 -- Complete annotation in case not done
569 Set_Normalized_Position
(Comp
, Cfbit
/ SSU
);
570 Set_Normalized_First_Bit
(Comp
, Cfbit
mod SSU
);
572 Esiz
:= Esize
(Comp
);
573 Sunit
:= Cfbit
/ SSU
;
577 if Unknown_Normalized_First_Bit
(Comp
) then
578 Set_Normalized_First_Bit
(Comp
, Uint_0
);
582 Natural'Max (Max_Suni_Length
, UI_Image_Length
);
585 Comp
:= Next_Entity
(Comp
);
588 -- Second loop does actual output based on those values
590 Comp
:= First_Entity
(Ent
);
591 while Present
(Comp
) loop
592 if Ekind
(Comp
) = E_Component
593 or else Ekind
(Comp
) = E_Discriminant
596 Esiz
: constant Uint
:= Esize
(Comp
);
597 Bofs
: constant Uint
:= Component_Bit_Offset
(Comp
);
598 Npos
: constant Uint
:= Normalized_Position
(Comp
);
599 Fbit
: constant Uint
:= Normalized_First_Bit
(Comp
);
604 Get_Decoded_Name_String
(Chars
(Comp
));
605 Set_Casing
(Unit_Casing
);
606 Write_Str
(Name_Buffer
(1 .. Name_Len
));
608 for J
in 1 .. Max_Name_Length
- Name_Len
loop
614 if Known_Static_Normalized_Position
(Comp
) then
616 Spaces
(Max_Suni_Length
- UI_Image_Length
);
617 Write_Str
(UI_Image_Buffer
(1 .. UI_Image_Length
));
619 elsif Known_Component_Bit_Offset
(Comp
)
620 and then List_Representation_Info
= 3
622 Spaces
(Max_Suni_Length
- 2);
623 Write_Val
(Bofs
, Paren
=> True);
626 elsif Known_Normalized_Position
(Comp
)
627 and then List_Representation_Info
= 3
629 Spaces
(Max_Suni_Length
- 2);
636 Write_Str
(" range ");
640 if not Is_Dynamic_SO_Ref
(Esize
(Comp
)) then
641 Lbit
:= Fbit
+ Esiz
- 1;
649 elsif List_Representation_Info
< 3 then
652 else -- List_Representation >= 3
654 Write_Val
(Esiz
, Paren
=> True);
656 -- If in front end layout mode, then dynamic size is
657 -- stored in storage units, so renormalize for output
659 if not Back_End_Layout
then
664 -- Add appropriate first bit offset
674 Write_Int
(UI_To_Int
(Fbit
) - 1);
682 Comp
:= Next_Entity
(Comp
);
685 Write_Line
("end record;");
686 end List_Record_Info
;
692 procedure List_Rep_Info
is
696 for U
in Main_Unit
.. Last_Unit
loop
697 if In_Extended_Main_Source_Unit
(Cunit_Entity
(U
)) then
698 Unit_Casing
:= Identifier_Casing
(Source_Index
(U
));
700 Write_Str
("Representation information for unit ");
701 Write_Unit_Name
(Unit_Name
(U
));
705 for J
in 1 .. Col
- 1 loop
710 List_Entities
(Cunit_Entity
(U
));
719 procedure List_Type_Info
(Ent
: Entity_Id
) is
723 -- If Esize and RM_Size are the same and known, list as Size. This
724 -- is a common case, which we may as well list in simple form.
726 if Esize
(Ent
) = RM_Size
(Ent
) then
727 if Known_Esize
(Ent
) then
730 Write_Str
("'Size use ");
731 Write_Val
(Esize
(Ent
));
735 -- For now, temporary case, to be removed when gigi properly back
736 -- annotates RM_Size, if RM_Size is not set, then list Esize as
737 -- Size. This avoids odd Object_Size output till we fix things???
739 elsif Unknown_RM_Size
(Ent
) then
740 if Known_Esize
(Ent
) then
743 Write_Str
("'Size use ");
744 Write_Val
(Esize
(Ent
));
748 -- Otherwise list size values separately if they are set
751 if Known_Esize
(Ent
) then
754 Write_Str
("'Object_Size use ");
755 Write_Val
(Esize
(Ent
));
759 -- Note on following check: The RM_Size of a discrete type can
760 -- legitimately be set to zero, so a special check is needed.
762 if Known_RM_Size
(Ent
) or else Is_Discrete_Type
(Ent
) then
765 Write_Str
("'Value_Size use ");
766 Write_Val
(RM_Size
(Ent
));
771 if Known_Alignment
(Ent
) then
774 Write_Str
("'Alignment use ");
775 Write_Val
(Alignment
(Ent
));
780 ----------------------
781 -- Rep_Not_Constant --
782 ----------------------
784 function Rep_Not_Constant
(Val
: Node_Ref_Or_Val
) return Boolean is
786 if Val
= No_Uint
or else Val
< 0 then
791 end Rep_Not_Constant
;
798 (Val
: Node_Ref_Or_Val
;
802 function B
(Val
: Boolean) return Uint
;
803 -- Returns Uint_0 for False, Uint_1 for True
805 function T
(Val
: Node_Ref_Or_Val
) return Boolean;
806 -- Returns True for 0, False for any non-zero (i.e. True)
808 function V
(Val
: Node_Ref_Or_Val
) return Uint
;
809 -- Internal recursive routine to evaluate tree
815 function B
(Val
: Boolean) return Uint
is
828 function T
(Val
: Node_Ref_Or_Val
) return Boolean is
841 function V
(Val
: Node_Ref_Or_Val
) return Uint
is
850 Node
: Exp_Node
renames Rep_Table
.Table
(-UI_To_Int
(Val
));
862 return V
(Node
.Op1
) + V
(Node
.Op2
);
865 return V
(Node
.Op1
) - V
(Node
.Op2
);
868 return V
(Node
.Op1
) * V
(Node
.Op2
);
870 when Trunc_Div_Expr
=>
871 return V
(Node
.Op1
) / V
(Node
.Op2
);
873 when Ceil_Div_Expr
=>
876 (V
(Node
.Op1
) / UR_From_Uint
(V
(Node
.Op2
)));
878 when Floor_Div_Expr
=>
881 (V
(Node
.Op1
) / UR_From_Uint
(V
(Node
.Op2
)));
883 when Trunc_Mod_Expr
=>
884 return V
(Node
.Op1
) rem V
(Node
.Op2
);
886 when Floor_Mod_Expr
=>
887 return V
(Node
.Op1
) mod V
(Node
.Op2
);
889 when Ceil_Mod_Expr
=>
892 Q
:= UR_Ceiling
(L
/ UR_From_Uint
(R
));
895 when Exact_Div_Expr
=>
896 return V
(Node
.Op1
) / V
(Node
.Op2
);
899 return -V
(Node
.Op1
);
902 return UI_Min
(V
(Node
.Op1
), V
(Node
.Op2
));
905 return UI_Max
(V
(Node
.Op1
), V
(Node
.Op2
));
908 return UI_Abs
(V
(Node
.Op1
));
910 when Truth_Andif_Expr
=>
911 return B
(T
(Node
.Op1
) and then T
(Node
.Op2
));
913 when Truth_Orif_Expr
=>
914 return B
(T
(Node
.Op1
) or else T
(Node
.Op2
));
916 when Truth_And_Expr
=>
917 return B
(T
(Node
.Op1
) and T
(Node
.Op2
));
919 when Truth_Or_Expr
=>
920 return B
(T
(Node
.Op1
) or T
(Node
.Op2
));
922 when Truth_Xor_Expr
=>
923 return B
(T
(Node
.Op1
) xor T
(Node
.Op2
));
925 when Truth_Not_Expr
=>
926 return B
(not T
(Node
.Op1
));
929 return B
(V
(Node
.Op1
) < V
(Node
.Op2
));
932 return B
(V
(Node
.Op1
) <= V
(Node
.Op2
));
935 return B
(V
(Node
.Op1
) > V
(Node
.Op2
));
938 return B
(V
(Node
.Op1
) >= V
(Node
.Op2
));
941 return B
(V
(Node
.Op1
) = V
(Node
.Op2
));
944 return B
(V
(Node
.Op1
) /= V
(Node
.Op2
));
948 Sub
: constant Int
:= UI_To_Int
(Node
.Op1
);
951 pragma Assert
(Sub
in D
'Range);
960 -- Start of processing for Rep_Value
963 if Val
= No_Uint
then
975 procedure Spaces
(N
: Natural) is
986 procedure Tree_Read
is
995 procedure Tree_Write
is
997 Rep_Table
.Tree_Write
;
1004 procedure Write_Val
(Val
: Node_Ref_Or_Val
; Paren
: Boolean := False) is
1006 if Rep_Not_Constant
(Val
) then
1007 if List_Representation_Info
< 3 then
1010 if Back_End_Layout
then
1012 List_GCC_Expression
(Val
);
1015 Write_Name_Decoded
(Chars
(Get_Dynamic_SO_Entity
(Val
)));