1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1999-2013, 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. --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Alloc
; use Alloc
;
33 with Atree
; use Atree
;
34 with Casing
; use Casing
;
35 with Debug
; use Debug
;
36 with Einfo
; use Einfo
;
38 with Namet
; use Namet
;
40 with Output
; use Output
;
41 with Sem_Aux
; use Sem_Aux
;
42 with Sinfo
; use Sinfo
;
43 with Sinput
; use Sinput
;
44 with Snames
; use Snames
;
45 with Stand
; use Stand
;
46 with Table
; use Table
;
47 with Uname
; use Uname
;
48 with Urealp
; use Urealp
;
50 with Ada
.Unchecked_Conversion
;
52 package body Repinfo
is
55 -- Value for Storage_Unit, we do not want to get this from TTypes, since
56 -- this introduces problematic dependencies in ASIS, and in any case this
57 -- value is assumed to be 8 for the implementation of the DDA.
59 -- This is wrong for AAMP???
61 ---------------------------------------
62 -- Representation of gcc Expressions --
63 ---------------------------------------
65 -- This table is used only if Frontend_Layout_On_Target is False, so gigi
66 -- lays out dynamic size/offset fields using encoded gcc expressions.
68 -- A table internal to this unit is used to hold the values of back
69 -- annotated expressions. This table is written out by -gnatt and read
70 -- back in for ASIS processing.
72 -- Node values are stored as Uint values using the negative of the node
73 -- index in this table. Constants appear as non-negative Uint values.
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 -- The following representation clause ensures that the above record
83 -- has no holes. We do this so that when instances of this record are
84 -- written by Tree_Gen, we do not write uninitialized values to the file.
86 for Exp_Node
use record
87 Expr
at 0 range 0 .. 31;
88 Op1
at 4 range 0 .. 31;
89 Op2
at 8 range 0 .. 31;
90 Op3
at 12 range 0 .. 31;
93 for Exp_Node
'Size use 16 * 8;
94 -- This ensures that we did not leave out any fields
96 package Rep_Table
is new Table
.Table
(
97 Table_Component_Type
=> Exp_Node
,
98 Table_Index_Type
=> Nat
,
100 Table_Initial
=> Alloc
.Rep_Table_Initial
,
101 Table_Increment
=> Alloc
.Rep_Table_Increment
,
102 Table_Name
=> "BE_Rep_Table");
104 --------------------------------------------------------------
105 -- Representation of Front-End Dynamic Size/Offset Entities --
106 --------------------------------------------------------------
108 package Dynamic_SO_Entity_Table
is new Table
.Table
(
109 Table_Component_Type
=> Entity_Id
,
110 Table_Index_Type
=> Nat
,
111 Table_Low_Bound
=> 1,
112 Table_Initial
=> Alloc
.Rep_Table_Initial
,
113 Table_Increment
=> Alloc
.Rep_Table_Increment
,
114 Table_Name
=> "FE_Rep_Table");
116 Unit_Casing
: Casing_Type
;
117 -- Identifier casing for current unit. This is set by List_Rep_Info for
118 -- each unit, before calling subprograms which may read it.
120 Need_Blank_Line
: Boolean;
121 -- Set True if a blank line is needed before outputting any information for
122 -- the current entity. Set True when a new entity is processed, and false
123 -- when the blank line is output.
125 -----------------------
126 -- Local Subprograms --
127 -----------------------
129 function Back_End_Layout
return Boolean;
130 -- Test for layout mode, True = back end, False = front end. This function
131 -- is used rather than checking the configuration parameter because we do
132 -- not want Repinfo to depend on Targparm (for ASIS)
134 procedure Blank_Line
;
135 -- Called before outputting anything for an entity. Ensures that
136 -- a blank line precedes the output for a particular entity.
138 procedure List_Entities
(Ent
: Entity_Id
; Bytes_Big_Endian
: Boolean);
139 -- This procedure lists the entities associated with the entity E, starting
140 -- with the First_Entity and using the Next_Entity link. If a nested
141 -- package is found, entities within the package are recursively processed.
143 procedure List_Name
(Ent
: Entity_Id
);
144 -- List name of entity Ent in appropriate case. The name is listed with
145 -- full qualification up to but not including the compilation unit name.
147 procedure List_Array_Info
(Ent
: Entity_Id
; Bytes_Big_Endian
: Boolean);
148 -- List representation info for array type Ent
150 procedure List_Mechanisms
(Ent
: Entity_Id
);
151 -- List mechanism information for parameters of Ent, which is subprogram,
152 -- subprogram type, or an entry or entry family.
154 procedure List_Object_Info
(Ent
: Entity_Id
);
155 -- List representation info for object Ent
157 procedure List_Record_Info
(Ent
: Entity_Id
; Bytes_Big_Endian
: Boolean);
158 -- List representation info for record type Ent
160 procedure List_Scalar_Storage_Order
162 Bytes_Big_Endian
: Boolean);
163 -- List scalar storage order information for record or array type Ent
165 procedure List_Type_Info
(Ent
: Entity_Id
);
166 -- List type info for type Ent
168 function Rep_Not_Constant
(Val
: Node_Ref_Or_Val
) return Boolean;
169 -- Returns True if Val represents a variable value, and False if it
170 -- represents a value that is fixed at compile time.
172 procedure Spaces
(N
: Natural);
173 -- Output given number of spaces
175 procedure Write_Info_Line
(S
: String);
176 -- Routine to write a line to Repinfo output file. This routine is passed
177 -- as a special output procedure to Output.Set_Special_Output. Note that
178 -- Write_Info_Line is called with an EOL character at the end of each line,
179 -- as per the Output spec, but the internal call to the appropriate routine
180 -- in Osint requires that the end of line sequence be stripped off.
182 procedure Write_Mechanism
(M
: Mechanism_Type
);
183 -- Writes symbolic string for mechanism represented by M
185 procedure Write_Val
(Val
: Node_Ref_Or_Val
; Paren
: Boolean := False);
186 -- Given a representation value, write it out. No_Uint values or values
187 -- dependent on discriminants are written as two question marks. If the
188 -- flag Paren is set, then the output is surrounded in parentheses if it is
189 -- other than a simple value.
191 ---------------------
192 -- Back_End_Layout --
193 ---------------------
195 function Back_End_Layout
return Boolean is
197 -- We have back end layout if the back end has made any entries in the
198 -- table of GCC expressions, otherwise we have front end layout.
200 return Rep_Table
.Last
> 0;
207 procedure Blank_Line
is
209 if Need_Blank_Line
then
211 Need_Blank_Line
:= False;
215 ------------------------
216 -- Create_Discrim_Ref --
217 ------------------------
219 function Create_Discrim_Ref
(Discr
: Entity_Id
) return Node_Ref
is
222 (Expr
=> Discrim_Val
,
223 Op1
=> Discriminant_Number
(Discr
));
224 end Create_Discrim_Ref
;
226 ---------------------------
227 -- Create_Dynamic_SO_Ref --
228 ---------------------------
230 function Create_Dynamic_SO_Ref
(E
: Entity_Id
) return Dynamic_SO_Ref
is
232 Dynamic_SO_Entity_Table
.Append
(E
);
233 return UI_From_Int
(-Dynamic_SO_Entity_Table
.Last
);
234 end Create_Dynamic_SO_Ref
;
242 Op1
: Node_Ref_Or_Val
;
243 Op2
: Node_Ref_Or_Val
:= No_Uint
;
244 Op3
: Node_Ref_Or_Val
:= No_Uint
) return Node_Ref
252 return UI_From_Int
(-Rep_Table
.Last
);
255 ---------------------------
256 -- Get_Dynamic_SO_Entity --
257 ---------------------------
259 function Get_Dynamic_SO_Entity
(U
: Dynamic_SO_Ref
) return Entity_Id
is
261 return Dynamic_SO_Entity_Table
.Table
(-UI_To_Int
(U
));
262 end Get_Dynamic_SO_Entity
;
264 -----------------------
265 -- Is_Dynamic_SO_Ref --
266 -----------------------
268 function Is_Dynamic_SO_Ref
(U
: SO_Ref
) return Boolean is
271 end Is_Dynamic_SO_Ref
;
273 ----------------------
274 -- Is_Static_SO_Ref --
275 ----------------------
277 function Is_Static_SO_Ref
(U
: SO_Ref
) return Boolean is
280 end Is_Static_SO_Ref
;
286 procedure lgx
(U
: Node_Ref_Or_Val
) is
288 List_GCC_Expression
(U
);
292 ----------------------
293 -- List_Array_Info --
294 ----------------------
296 procedure List_Array_Info
(Ent
: Entity_Id
; Bytes_Big_Endian
: Boolean) is
298 List_Type_Info
(Ent
);
301 Write_Str
("'Component_Size use ");
302 Write_Val
(Component_Size
(Ent
));
305 List_Scalar_Storage_Order
(Ent
, Bytes_Big_Endian
);
312 procedure List_Entities
(Ent
: Entity_Id
; Bytes_Big_Endian
: Boolean) is
316 function Find_Declaration
(E
: Entity_Id
) return Node_Id
;
317 -- Utility to retrieve declaration node for entity in the
318 -- case of package bodies and subprograms.
320 ----------------------
321 -- Find_Declaration --
322 ----------------------
324 function Find_Declaration
(E
: Entity_Id
) return Node_Id
is
330 and then Nkind
(Decl
) /= N_Package_Body
331 and then Nkind
(Decl
) /= N_Subprogram_Declaration
332 and then Nkind
(Decl
) /= N_Subprogram_Body
334 Decl
:= Parent
(Decl
);
338 end Find_Declaration
;
340 -- Start of processing for List_Entities
343 -- List entity if we have one, and it is not a renaming declaration.
344 -- For renamings, we don't get proper information, and really it makes
345 -- sense to restrict the output to the renamed entity.
348 and then Nkind
(Declaration_Node
(Ent
)) not in N_Renaming_Declaration
350 -- If entity is a subprogram and we are listing mechanisms,
351 -- then we need to list mechanisms for this entity.
353 if List_Representation_Info_Mechanisms
354 and then (Is_Subprogram
(Ent
)
355 or else Ekind
(Ent
) = E_Entry
356 or else Ekind
(Ent
) = E_Entry_Family
)
358 Need_Blank_Line
:= True;
359 List_Mechanisms
(Ent
);
362 E
:= First_Entity
(Ent
);
363 while Present
(E
) loop
364 Need_Blank_Line
:= True;
366 -- We list entities that come from source (excluding private or
367 -- incomplete types or deferred constants, where we will list the
368 -- info for the full view). If debug flag A is set, then all
369 -- entities are listed
371 if (Comes_From_Source
(E
)
372 and then not Is_Incomplete_Or_Private_Type
(E
)
373 and then not (Ekind
(E
) = E_Constant
374 and then Present
(Full_View
(E
))))
375 or else Debug_Flag_AA
381 Ekind
(E
) = E_Entry_Family
383 Ekind
(E
) = E_Subprogram_Type
385 if List_Representation_Info_Mechanisms
then
389 elsif Is_Record_Type
(E
) then
390 if List_Representation_Info
>= 1 then
391 List_Record_Info
(E
, Bytes_Big_Endian
);
394 elsif Is_Array_Type
(E
) then
395 if List_Representation_Info
>= 1 then
396 List_Array_Info
(E
, Bytes_Big_Endian
);
399 elsif Is_Type
(E
) then
400 if List_Representation_Info
>= 2 then
404 elsif Ekind
(E
) = E_Variable
406 Ekind
(E
) = E_Constant
408 Ekind
(E
) = E_Loop_Parameter
412 if List_Representation_Info
>= 2 then
413 List_Object_Info
(E
);
417 -- Recurse into nested package, but not if they are package
418 -- renamings (in particular renamings of the enclosing package,
419 -- as for some Java bindings and for generic instances).
421 if Ekind
(E
) = E_Package
then
422 if No
(Renamed_Object
(E
)) then
423 List_Entities
(E
, Bytes_Big_Endian
);
426 -- Recurse into bodies
428 elsif Ekind
(E
) = E_Protected_Type
430 Ekind
(E
) = E_Task_Type
432 Ekind
(E
) = E_Subprogram_Body
434 Ekind
(E
) = E_Package_Body
436 Ekind
(E
) = E_Task_Body
438 Ekind
(E
) = E_Protected_Body
440 List_Entities
(E
, Bytes_Big_Endian
);
442 -- Recurse into blocks
444 elsif Ekind
(E
) = E_Block
then
445 List_Entities
(E
, Bytes_Big_Endian
);
449 E
:= Next_Entity
(E
);
452 -- For a package body, the entities of the visible subprograms are
453 -- declared in the corresponding spec. Iterate over its entities in
454 -- order to handle properly the subprogram bodies. Skip bodies in
455 -- subunits, which are listed independently.
457 if Ekind
(Ent
) = E_Package_Body
458 and then Present
(Corresponding_Spec
(Find_Declaration
(Ent
)))
460 E
:= First_Entity
(Corresponding_Spec
(Find_Declaration
(Ent
)));
461 while Present
(E
) loop
464 Nkind
(Find_Declaration
(E
)) = N_Subprogram_Declaration
466 Body_E
:= Corresponding_Body
(Find_Declaration
(E
));
470 Nkind
(Parent
(Find_Declaration
(Body_E
))) /= N_Subunit
472 List_Entities
(Body_E
, Bytes_Big_Endian
);
482 -------------------------
483 -- List_GCC_Expression --
484 -------------------------
486 procedure List_GCC_Expression
(U
: Node_Ref_Or_Val
) is
488 procedure Print_Expr
(Val
: Node_Ref_Or_Val
);
489 -- Internal recursive procedure to print expression
495 procedure Print_Expr
(Val
: Node_Ref_Or_Val
) is
498 UI_Write
(Val
, Decimal
);
502 Node
: Exp_Node
renames Rep_Table
.Table
(-UI_To_Int
(Val
));
504 procedure Binop
(S
: String);
505 -- Output text for binary operator with S being operator name
511 procedure Binop
(S
: String) is
514 Print_Expr
(Node
.Op1
);
516 Print_Expr
(Node
.Op2
);
520 -- Start of processing for Print_Expr
526 Print_Expr
(Node
.Op1
);
527 Write_Str
(" then ");
528 Print_Expr
(Node
.Op2
);
529 Write_Str
(" else ");
530 Print_Expr
(Node
.Op3
);
542 when Trunc_Div_Expr
=>
545 when Ceil_Div_Expr
=>
548 when Floor_Div_Expr
=>
551 when Trunc_Mod_Expr
=>
554 when Floor_Mod_Expr
=>
557 when Ceil_Mod_Expr
=>
560 when Exact_Div_Expr
=>
565 Print_Expr
(Node
.Op1
);
575 Print_Expr
(Node
.Op1
);
577 when Truth_Andif_Expr
=>
580 when Truth_Orif_Expr
=>
583 when Truth_And_Expr
=>
586 when Truth_Or_Expr
=>
589 when Truth_Xor_Expr
=>
592 when Truth_Not_Expr
=>
594 Print_Expr
(Node
.Op1
);
626 -- Start of processing for List_GCC_Expression
634 end List_GCC_Expression
;
636 ---------------------
637 -- List_Mechanisms --
638 ---------------------
640 procedure List_Mechanisms
(Ent
: Entity_Id
) is
649 Write_Str
("function ");
652 Write_Str
("operator ");
655 Write_Str
("procedure ");
657 when E_Subprogram_Type
=>
660 when E_Entry | E_Entry_Family
=>
661 Write_Str
("entry ");
667 Get_Unqualified_Decoded_Name_String
(Chars
(Ent
));
668 Write_Str
(Name_Buffer
(1 .. Name_Len
));
669 Write_Str
(" declared at ");
670 Write_Location
(Sloc
(Ent
));
673 Write_Str
(" convention : ");
675 case Convention
(Ent
) is
676 when Convention_Ada
=>
678 when Convention_Ada_Pass_By_Copy
=>
679 Write_Line
("Ada_Pass_By_Copy");
680 when Convention_Ada_Pass_By_Reference
=>
681 Write_Line
("Ada_Pass_By_Reference");
682 when Convention_Intrinsic
=>
683 Write_Line
("Intrinsic");
684 when Convention_Entry
=>
685 Write_Line
("Entry");
686 when Convention_Ghost
=>
687 Write_Line
("Ghost");
688 when Convention_Protected
=>
689 Write_Line
("Protected");
690 when Convention_Assembler
=>
691 Write_Line
("Assembler");
694 when Convention_CIL
=>
696 when Convention_COBOL
=>
697 Write_Line
("COBOL");
698 when Convention_CPP
=>
700 when Convention_Fortran
=>
701 Write_Line
("Fortran");
702 when Convention_Java
=>
704 when Convention_Stdcall
=>
705 Write_Line
("Stdcall");
706 when Convention_Stubbed
=>
707 Write_Line
("Stubbed");
710 -- Find max length of formal name
713 Form
:= First_Formal
(Ent
);
714 while Present
(Form
) loop
715 Get_Unqualified_Decoded_Name_String
(Chars
(Form
));
717 if Name_Len
> Plen
then
724 -- Output formals and mechanisms
726 Form
:= First_Formal
(Ent
);
727 while Present
(Form
) loop
728 Get_Unqualified_Decoded_Name_String
(Chars
(Form
));
729 while Name_Len
<= Plen
loop
730 Name_Len
:= Name_Len
+ 1;
731 Name_Buffer
(Name_Len
) := ' ';
735 Write_Str
(Name_Buffer
(1 .. Plen
+ 1));
736 Write_Str
(": passed by ");
738 Write_Mechanism
(Mechanism
(Form
));
743 if Etype
(Ent
) /= Standard_Void_Type
then
744 Write_Str
(" returns by ");
745 Write_Mechanism
(Mechanism
(Ent
));
754 procedure List_Name
(Ent
: Entity_Id
) is
756 if not Is_Compilation_Unit
(Scope
(Ent
)) then
757 List_Name
(Scope
(Ent
));
761 Get_Unqualified_Decoded_Name_String
(Chars
(Ent
));
762 Set_Casing
(Unit_Casing
);
763 Write_Str
(Name_Buffer
(1 .. Name_Len
));
766 ---------------------
767 -- List_Object_Info --
768 ---------------------
770 procedure List_Object_Info
(Ent
: Entity_Id
) is
776 Write_Str
("'Size use ");
777 Write_Val
(Esize
(Ent
));
782 Write_Str
("'Alignment use ");
783 Write_Val
(Alignment
(Ent
));
785 end List_Object_Info
;
787 ----------------------
788 -- List_Record_Info --
789 ----------------------
791 procedure List_Record_Info
(Ent
: Entity_Id
; Bytes_Big_Endian
: Boolean) is
796 Max_Name_Length
: Natural;
797 Max_Suni_Length
: Natural;
801 List_Type_Info
(Ent
);
805 Write_Line
(" use record");
807 -- First loop finds out max line length and max starting position
808 -- length, for the purpose of lining things up nicely.
810 Max_Name_Length
:= 0;
811 Max_Suni_Length
:= 0;
813 Comp
:= First_Component_Or_Discriminant
(Ent
);
814 while Present
(Comp
) loop
815 Get_Decoded_Name_String
(Chars
(Comp
));
816 Max_Name_Length
:= Natural'Max (Max_Name_Length
, Name_Len
);
818 Cfbit
:= Component_Bit_Offset
(Comp
);
820 if Rep_Not_Constant
(Cfbit
) then
821 UI_Image_Length
:= 2;
824 -- Complete annotation in case not done
826 Set_Normalized_Position
(Comp
, Cfbit
/ SSU
);
827 Set_Normalized_First_Bit
(Comp
, Cfbit
mod SSU
);
829 Sunit
:= Cfbit
/ SSU
;
833 -- If the record is not packed, then we know that all fields whose
834 -- position is not specified have a starting normalized bit position
837 if Unknown_Normalized_First_Bit
(Comp
)
838 and then not Is_Packed
(Ent
)
840 Set_Normalized_First_Bit
(Comp
, Uint_0
);
844 Natural'Max (Max_Suni_Length
, UI_Image_Length
);
846 Next_Component_Or_Discriminant
(Comp
);
849 -- Second loop does actual output based on those values
851 Comp
:= First_Component_Or_Discriminant
(Ent
);
852 while Present
(Comp
) loop
854 Esiz
: constant Uint
:= Esize
(Comp
);
855 Bofs
: constant Uint
:= Component_Bit_Offset
(Comp
);
856 Npos
: constant Uint
:= Normalized_Position
(Comp
);
857 Fbit
: constant Uint
:= Normalized_First_Bit
(Comp
);
862 Get_Decoded_Name_String
(Chars
(Comp
));
863 Set_Casing
(Unit_Casing
);
864 Write_Str
(Name_Buffer
(1 .. Name_Len
));
866 for J
in 1 .. Max_Name_Length
- Name_Len
loop
872 if Known_Static_Normalized_Position
(Comp
) then
874 Spaces
(Max_Suni_Length
- UI_Image_Length
);
875 Write_Str
(UI_Image_Buffer
(1 .. UI_Image_Length
));
877 elsif Known_Component_Bit_Offset
(Comp
)
878 and then List_Representation_Info
= 3
880 Spaces
(Max_Suni_Length
- 2);
881 Write_Str
("bit offset");
882 Write_Val
(Bofs
, Paren
=> True);
883 Write_Str
(" size in bits = ");
884 Write_Val
(Esiz
, Paren
=> True);
888 elsif Known_Normalized_Position
(Comp
)
889 and then List_Representation_Info
= 3
891 Spaces
(Max_Suni_Length
- 2);
895 -- For the packed case, we don't know the bit positions if we
896 -- don't know the starting position!
898 if Is_Packed
(Ent
) then
899 Write_Line
("?? range ? .. ??;");
902 -- Otherwise we can continue
909 Write_Str
(" range ");
913 -- Allowing Uint_0 here is a kludge, really this should be a
914 -- fine Esize value but currently it means unknown, except that
915 -- we know after gigi has back annotated that a size of zero is
916 -- real, since otherwise gigi back annotates using No_Uint as
917 -- the value to indicate unknown).
919 if (Esize
(Comp
) = Uint_0
or else Known_Static_Esize
(Comp
))
920 and then Known_Static_Normalized_First_Bit
(Comp
)
922 Lbit
:= Fbit
+ Esiz
- 1;
930 -- The test for Esize (Comp) not being Uint_0 here is a kludge.
931 -- Officially a value of zero for Esize means unknown, but here
932 -- we use the fact that we know that gigi annotates Esize with
933 -- No_Uint, not Uint_0. Really everyone should use No_Uint???
935 elsif List_Representation_Info
< 3
936 or else (Esize
(Comp
) /= Uint_0
and then Unknown_Esize
(Comp
))
940 -- List_Representation >= 3 and Known_Esize (Comp)
943 Write_Val
(Esiz
, Paren
=> True);
945 -- If in front end layout mode, then dynamic size is stored
946 -- in storage units, so renormalize for output
948 if not Back_End_Layout
then
953 -- Add appropriate first bit offset
963 Write_Int
(UI_To_Int
(Fbit
) - 1);
971 Next_Component_Or_Discriminant
(Comp
);
974 Write_Line
("end record;");
976 List_Scalar_Storage_Order
(Ent
, Bytes_Big_Endian
);
977 end List_Record_Info
;
983 procedure List_Rep_Info
(Bytes_Big_Endian
: Boolean) is
987 if List_Representation_Info
/= 0
988 or else List_Representation_Info_Mechanisms
990 for U
in Main_Unit
.. Last_Unit
loop
991 if In_Extended_Main_Source_Unit
(Cunit_Entity
(U
)) then
992 Unit_Casing
:= Identifier_Casing
(Source_Index
(U
));
994 -- Normal case, list to standard output
996 if not List_Representation_Info_To_File
then
998 Write_Str
("Representation information for unit ");
999 Write_Unit_Name
(Unit_Name
(U
));
1003 for J
in 1 .. Col
- 1 loop
1008 List_Entities
(Cunit_Entity
(U
), Bytes_Big_Endian
);
1010 -- List representation information to file
1013 Create_Repinfo_File_Access
.all
1014 (Get_Name_String
(File_Name
(Source_Index
(U
))));
1015 Set_Special_Output
(Write_Info_Line
'Access);
1016 List_Entities
(Cunit_Entity
(U
), Bytes_Big_Endian
);
1017 Set_Special_Output
(null);
1018 Close_Repinfo_File_Access
.all;
1025 -------------------------------
1026 -- List_Scalar_Storage_Order --
1027 -------------------------------
1029 procedure List_Scalar_Storage_Order
1031 Bytes_Big_Endian
: Boolean)
1033 procedure List_Attr
(Attr_Name
: String);
1034 -- Show attribute definition clause for Attr_Name
1040 procedure List_Attr
(Attr_Name
: String) is
1044 Write_Str
("'" & Attr_Name
& " use System.");
1046 if Bytes_Big_Endian
xor Reverse_Storage_Order
(Ent
) then
1052 Write_Line
("_Order_First;");
1055 -- Start of processing for List_Scalar_Storage_Order
1058 if Has_Rep_Item
(Ent
, Name_Scalar_Storage_Order
) then
1060 -- For a record type with explicitly specified scalar storage order,
1061 -- also display explicit Bit_Order.
1063 if Is_Record_Type
(Ent
) then
1064 List_Attr
("Bit_Order");
1067 List_Attr
("Scalar_Storage_Order");
1069 end List_Scalar_Storage_Order
;
1071 --------------------
1072 -- List_Type_Info --
1073 --------------------
1075 procedure List_Type_Info
(Ent
: Entity_Id
) is
1079 -- Do not list size info for unconstrained arrays, not meaningful
1081 if Is_Array_Type
(Ent
) and then not Is_Constrained
(Ent
) then
1085 -- If Esize and RM_Size are the same and known, list as Size. This
1086 -- is a common case, which we may as well list in simple form.
1088 if Esize
(Ent
) = RM_Size
(Ent
) then
1091 Write_Str
("'Size use ");
1092 Write_Val
(Esize
(Ent
));
1095 -- For now, temporary case, to be removed when gigi properly back
1096 -- annotates RM_Size, if RM_Size is not set, then list Esize as Size.
1097 -- This avoids odd Object_Size output till we fix things???
1099 elsif Unknown_RM_Size
(Ent
) then
1102 Write_Str
("'Size use ");
1103 Write_Val
(Esize
(Ent
));
1106 -- Otherwise list size values separately if they are set
1111 Write_Str
("'Object_Size use ");
1112 Write_Val
(Esize
(Ent
));
1115 -- Note on following check: The RM_Size of a discrete type can
1116 -- legitimately be set to zero, so a special check is needed.
1120 Write_Str
("'Value_Size use ");
1121 Write_Val
(RM_Size
(Ent
));
1128 Write_Str
("'Alignment use ");
1129 Write_Val
(Alignment
(Ent
));
1132 -- Special stuff for fixed-point
1134 if Is_Fixed_Point_Type
(Ent
) then
1136 -- Write small (always a static constant)
1140 Write_Str
("'Small use ");
1141 UR_Write
(Small_Value
(Ent
));
1144 -- Write range if static
1147 R
: constant Node_Id
:= Scalar_Range
(Ent
);
1150 if Nkind
(Low_Bound
(R
)) = N_Real_Literal
1152 Nkind
(High_Bound
(R
)) = N_Real_Literal
1156 Write_Str
("'Range use ");
1157 UR_Write
(Realval
(Low_Bound
(R
)));
1159 UR_Write
(Realval
(High_Bound
(R
)));
1166 ----------------------
1167 -- Rep_Not_Constant --
1168 ----------------------
1170 function Rep_Not_Constant
(Val
: Node_Ref_Or_Val
) return Boolean is
1172 if Val
= No_Uint
or else Val
< 0 then
1177 end Rep_Not_Constant
;
1184 (Val
: Node_Ref_Or_Val
;
1185 D
: Discrim_List
) return Uint
1187 function B
(Val
: Boolean) return Uint
;
1188 -- Returns Uint_0 for False, Uint_1 for True
1190 function T
(Val
: Node_Ref_Or_Val
) return Boolean;
1191 -- Returns True for 0, False for any non-zero (i.e. True)
1193 function V
(Val
: Node_Ref_Or_Val
) return Uint
;
1194 -- Internal recursive routine to evaluate tree
1196 function W
(Val
: Uint
) return Word
;
1197 -- Convert Val to Word, assuming Val is always in the Int range. This
1198 -- is a helper function for the evaluation of bitwise expressions like
1199 -- Bit_And_Expr, for which there is no direct support in uintp. Uint
1200 -- values out of the Int range are expected to be seen in such
1201 -- expressions only with overflowing byte sizes around, introducing
1202 -- inherent unreliabilities in computations anyway.
1208 function B
(Val
: Boolean) return Uint
is
1221 function T
(Val
: Node_Ref_Or_Val
) return Boolean is
1234 function V
(Val
: Node_Ref_Or_Val
) return Uint
is
1243 Node
: Exp_Node
renames Rep_Table
.Table
(-UI_To_Int
(Val
));
1248 if T
(Node
.Op1
) then
1249 return V
(Node
.Op2
);
1251 return V
(Node
.Op3
);
1255 return V
(Node
.Op1
) + V
(Node
.Op2
);
1258 return V
(Node
.Op1
) - V
(Node
.Op2
);
1261 return V
(Node
.Op1
) * V
(Node
.Op2
);
1263 when Trunc_Div_Expr
=>
1264 return V
(Node
.Op1
) / V
(Node
.Op2
);
1266 when Ceil_Div_Expr
=>
1269 (V
(Node
.Op1
) / UR_From_Uint
(V
(Node
.Op2
)));
1271 when Floor_Div_Expr
=>
1274 (V
(Node
.Op1
) / UR_From_Uint
(V
(Node
.Op2
)));
1276 when Trunc_Mod_Expr
=>
1277 return V
(Node
.Op1
) rem V
(Node
.Op2
);
1279 when Floor_Mod_Expr
=>
1280 return V
(Node
.Op1
) mod V
(Node
.Op2
);
1282 when Ceil_Mod_Expr
=>
1285 Q
:= UR_Ceiling
(L
/ UR_From_Uint
(R
));
1288 when Exact_Div_Expr
=>
1289 return V
(Node
.Op1
) / V
(Node
.Op2
);
1292 return -V
(Node
.Op1
);
1295 return UI_Min
(V
(Node
.Op1
), V
(Node
.Op2
));
1298 return UI_Max
(V
(Node
.Op1
), V
(Node
.Op2
));
1301 return UI_Abs
(V
(Node
.Op1
));
1303 when Truth_Andif_Expr
=>
1304 return B
(T
(Node
.Op1
) and then T
(Node
.Op2
));
1306 when Truth_Orif_Expr
=>
1307 return B
(T
(Node
.Op1
) or else T
(Node
.Op2
));
1309 when Truth_And_Expr
=>
1310 return B
(T
(Node
.Op1
) and then T
(Node
.Op2
));
1312 when Truth_Or_Expr
=>
1313 return B
(T
(Node
.Op1
) or else T
(Node
.Op2
));
1315 when Truth_Xor_Expr
=>
1316 return B
(T
(Node
.Op1
) xor T
(Node
.Op2
));
1318 when Truth_Not_Expr
=>
1319 return B
(not T
(Node
.Op1
));
1321 when Bit_And_Expr
=>
1324 return UI_From_Int
(Int
(W
(L
) and W
(R
)));
1327 return B
(V
(Node
.Op1
) < V
(Node
.Op2
));
1330 return B
(V
(Node
.Op1
) <= V
(Node
.Op2
));
1333 return B
(V
(Node
.Op1
) > V
(Node
.Op2
));
1336 return B
(V
(Node
.Op1
) >= V
(Node
.Op2
));
1339 return B
(V
(Node
.Op1
) = V
(Node
.Op2
));
1342 return B
(V
(Node
.Op1
) /= V
(Node
.Op2
));
1346 Sub
: constant Int
:= UI_To_Int
(Node
.Op1
);
1348 pragma Assert
(Sub
in D
'Range);
1361 -- We use an unchecked conversion to map Int values to their Word
1362 -- bitwise equivalent, which we could not achieve with a normal type
1363 -- conversion for negative Ints. We want bitwise equivalents because W
1364 -- is used as a helper for bit operators like Bit_And_Expr, and can be
1365 -- called for negative Ints in the context of aligning expressions like
1366 -- X+Align & -Align.
1368 function W
(Val
: Uint
) return Word
is
1369 function To_Word
is new Ada
.Unchecked_Conversion
(Int
, Word
);
1371 return To_Word
(UI_To_Int
(Val
));
1374 -- Start of processing for Rep_Value
1377 if Val
= No_Uint
then
1389 procedure Spaces
(N
: Natural) is
1391 for J
in 1 .. N
loop
1400 procedure Tree_Read
is
1402 Rep_Table
.Tree_Read
;
1409 procedure Tree_Write
is
1411 Rep_Table
.Tree_Write
;
1414 ---------------------
1415 -- Write_Info_Line --
1416 ---------------------
1418 procedure Write_Info_Line
(S
: String) is
1420 Write_Repinfo_Line_Access
.all (S
(S
'First .. S
'Last - 1));
1421 end Write_Info_Line
;
1423 ---------------------
1424 -- Write_Mechanism --
1425 ---------------------
1427 procedure Write_Mechanism
(M
: Mechanism_Type
) is
1431 Write_Str
("default");
1437 Write_Str
("reference");
1440 Write_Str
("descriptor");
1443 Write_Str
("descriptor (UBS)");
1446 Write_Str
("descriptor (UBSB)");
1449 Write_Str
("descriptor (UBA)");
1452 Write_Str
("descriptor (S)");
1455 Write_Str
("descriptor (SB)");
1458 Write_Str
("descriptor (A)");
1461 Write_Str
("descriptor (NCA)");
1464 raise Program_Error
;
1466 end Write_Mechanism
;
1472 procedure Write_Val
(Val
: Node_Ref_Or_Val
; Paren
: Boolean := False) is
1474 if Rep_Not_Constant
(Val
) then
1475 if List_Representation_Info
< 3 or else Val
= No_Uint
then
1479 if Back_End_Layout
then
1484 List_GCC_Expression
(Val
);
1487 List_GCC_Expression
(Val
);
1495 Write_Name_Decoded
(Chars
(Get_Dynamic_SO_Entity
(Val
)));
1498 Write_Name_Decoded
(Chars
(Get_Dynamic_SO_Entity
(Val
)));