1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1999-2010, 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 Sinfo
; use Sinfo
;
42 with Sinput
; use Sinput
;
43 with Snames
; use Snames
;
44 with Stand
; use Stand
;
45 with Table
; use Table
;
46 with Uname
; use Uname
;
47 with Urealp
; use Urealp
;
49 with Ada
.Unchecked_Conversion
;
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.
58 -- This is wrong for AAMP???
60 ---------------------------------------
61 -- Representation of gcc Expressions --
62 ---------------------------------------
64 -- This table is used only if Frontend_Layout_On_Target is False, so gigi
65 -- lays out dynamic size/offset fields using encoded gcc expressions.
67 -- A table internal to this unit is used to hold the values of back
68 -- annotated expressions. This table is written out by -gnatt and read
69 -- back in for ASIS processing.
71 -- Node values are stored as Uint values using the negative of the node
72 -- index in this table. Constants appear as non-negative Uint values.
74 type Exp_Node
is record
76 Op1
: Node_Ref_Or_Val
;
77 Op2
: Node_Ref_Or_Val
;
78 Op3
: Node_Ref_Or_Val
;
81 -- The following representation clause ensures that the above record
82 -- has no holes. We do this so that when instances of this record are
83 -- written by Tree_Gen, we do not write uninitialized values to the file.
85 for Exp_Node
use record
86 Expr
at 0 range 0 .. 31;
87 Op1
at 4 range 0 .. 31;
88 Op2
at 8 range 0 .. 31;
89 Op3
at 12 range 0 .. 31;
92 for Exp_Node
'Size use 16 * 8;
93 -- This ensures that we did not leave out any fields
95 package Rep_Table
is new Table
.Table
(
96 Table_Component_Type
=> Exp_Node
,
97 Table_Index_Type
=> Nat
,
99 Table_Initial
=> Alloc
.Rep_Table_Initial
,
100 Table_Increment
=> Alloc
.Rep_Table_Increment
,
101 Table_Name
=> "BE_Rep_Table");
103 --------------------------------------------------------------
104 -- Representation of Front-End Dynamic Size/Offset Entities --
105 --------------------------------------------------------------
107 package Dynamic_SO_Entity_Table
is new Table
.Table
(
108 Table_Component_Type
=> Entity_Id
,
109 Table_Index_Type
=> Nat
,
110 Table_Low_Bound
=> 1,
111 Table_Initial
=> Alloc
.Rep_Table_Initial
,
112 Table_Increment
=> Alloc
.Rep_Table_Increment
,
113 Table_Name
=> "FE_Rep_Table");
115 Unit_Casing
: Casing_Type
;
116 -- Identifier casing for current unit
118 Need_Blank_Line
: Boolean;
119 -- Set True if a blank line is needed before outputting any information for
120 -- the current entity. Set True when a new entity is processed, and false
121 -- when the blank line is output.
123 -----------------------
124 -- Local Subprograms --
125 -----------------------
127 function Back_End_Layout
return Boolean;
128 -- Test for layout mode, True = back end, False = front end. This function
129 -- is used rather than checking the configuration parameter because we do
130 -- not want Repinfo to depend on Targparm (for ASIS)
132 procedure Blank_Line
;
133 -- Called before outputting anything for an entity. Ensures that
134 -- a blank line precedes the output for a particular entity.
136 procedure List_Entities
(Ent
: Entity_Id
);
137 -- This procedure lists the entities associated with the entity E, starting
138 -- with the First_Entity and using the Next_Entity link. If a nested
139 -- package is found, entities within the package are recursively processed.
141 procedure List_Name
(Ent
: Entity_Id
);
142 -- List name of entity Ent in appropriate case. The name is listed with
143 -- full qualification up to but not including the compilation unit name.
145 procedure List_Array_Info
(Ent
: Entity_Id
);
146 -- List representation info for array type Ent
148 procedure List_Mechanisms
(Ent
: Entity_Id
);
149 -- List mechanism information for parameters of Ent, which is subprogram,
150 -- subprogram type, or an entry or entry family.
152 procedure List_Object_Info
(Ent
: Entity_Id
);
153 -- List representation info for object Ent
155 procedure List_Record_Info
(Ent
: Entity_Id
);
156 -- List representation info for record type Ent
158 procedure List_Type_Info
(Ent
: Entity_Id
);
159 -- List type info for type Ent
161 function Rep_Not_Constant
(Val
: Node_Ref_Or_Val
) return Boolean;
162 -- Returns True if Val represents a variable value, and False if it
163 -- represents a value that is fixed at compile time.
165 procedure Spaces
(N
: Natural);
166 -- Output given number of spaces
168 procedure Write_Info_Line
(S
: String);
169 -- Routine to write a line to Repinfo output file. This routine is passed
170 -- as a special output procedure to Output.Set_Special_Output. Note that
171 -- Write_Info_Line is called with an EOL character at the end of each line,
172 -- as per the Output spec, but the internal call to the appropriate routine
173 -- in Osint requires that the end of line sequence be stripped off.
175 procedure Write_Mechanism
(M
: Mechanism_Type
);
176 -- Writes symbolic string for mechanism represented by M
178 procedure Write_Val
(Val
: Node_Ref_Or_Val
; Paren
: Boolean := False);
179 -- Given a representation value, write it out. No_Uint values or values
180 -- dependent on discriminants are written as two question marks. If the
181 -- flag Paren is set, then the output is surrounded in parentheses if it is
182 -- other than a simple value.
184 ---------------------
185 -- Back_End_Layout --
186 ---------------------
188 function Back_End_Layout
return Boolean is
190 -- We have back end layout if the back end has made any entries in the
191 -- table of GCC expressions, otherwise we have front end layout.
193 return Rep_Table
.Last
> 0;
200 procedure Blank_Line
is
202 if Need_Blank_Line
then
204 Need_Blank_Line
:= False;
208 ------------------------
209 -- Create_Discrim_Ref --
210 ------------------------
212 function Create_Discrim_Ref
(Discr
: Entity_Id
) return Node_Ref
is
215 (Expr
=> Discrim_Val
,
216 Op1
=> Discriminant_Number
(Discr
));
217 end Create_Discrim_Ref
;
219 ---------------------------
220 -- Create_Dynamic_SO_Ref --
221 ---------------------------
223 function Create_Dynamic_SO_Ref
(E
: Entity_Id
) return Dynamic_SO_Ref
is
225 Dynamic_SO_Entity_Table
.Append
(E
);
226 return UI_From_Int
(-Dynamic_SO_Entity_Table
.Last
);
227 end Create_Dynamic_SO_Ref
;
235 Op1
: Node_Ref_Or_Val
;
236 Op2
: Node_Ref_Or_Val
:= No_Uint
;
237 Op3
: Node_Ref_Or_Val
:= No_Uint
) return Node_Ref
245 return UI_From_Int
(-Rep_Table
.Last
);
248 ---------------------------
249 -- Get_Dynamic_SO_Entity --
250 ---------------------------
252 function Get_Dynamic_SO_Entity
(U
: Dynamic_SO_Ref
) return Entity_Id
is
254 return Dynamic_SO_Entity_Table
.Table
(-UI_To_Int
(U
));
255 end Get_Dynamic_SO_Entity
;
257 -----------------------
258 -- Is_Dynamic_SO_Ref --
259 -----------------------
261 function Is_Dynamic_SO_Ref
(U
: SO_Ref
) return Boolean is
264 end Is_Dynamic_SO_Ref
;
266 ----------------------
267 -- Is_Static_SO_Ref --
268 ----------------------
270 function Is_Static_SO_Ref
(U
: SO_Ref
) return Boolean is
273 end Is_Static_SO_Ref
;
279 procedure lgx
(U
: Node_Ref_Or_Val
) is
281 List_GCC_Expression
(U
);
285 ----------------------
286 -- List_Array_Info --
287 ----------------------
289 procedure List_Array_Info
(Ent
: Entity_Id
) is
291 List_Type_Info
(Ent
);
294 Write_Str
("'Component_Size use ");
295 Write_Val
(Component_Size
(Ent
));
303 procedure List_Entities
(Ent
: Entity_Id
) is
307 function Find_Declaration
(E
: Entity_Id
) return Node_Id
;
308 -- Utility to retrieve declaration node for entity in the
309 -- case of package bodies and subprograms.
311 ----------------------
312 -- Find_Declaration --
313 ----------------------
315 function Find_Declaration
(E
: Entity_Id
) return Node_Id
is
321 and then Nkind
(Decl
) /= N_Package_Body
322 and then Nkind
(Decl
) /= N_Subprogram_Declaration
323 and then Nkind
(Decl
) /= N_Subprogram_Body
325 Decl
:= Parent
(Decl
);
329 end Find_Declaration
;
331 -- Start of processing for List_Entities
334 -- List entity if we have one, and it is not a renaming declaration.
335 -- For renamings, we don't get proper information, and really it makes
336 -- sense to restrict the output to the renamed entity.
339 and then Nkind
(Declaration_Node
(Ent
)) not in N_Renaming_Declaration
341 -- If entity is a subprogram and we are listing mechanisms,
342 -- then we need to list mechanisms for this entity.
344 if List_Representation_Info_Mechanisms
345 and then (Is_Subprogram
(Ent
)
346 or else Ekind
(Ent
) = E_Entry
347 or else Ekind
(Ent
) = E_Entry_Family
)
349 Need_Blank_Line
:= True;
350 List_Mechanisms
(Ent
);
353 E
:= First_Entity
(Ent
);
354 while Present
(E
) loop
355 Need_Blank_Line
:= True;
357 -- We list entities that come from source (excluding private or
358 -- incomplete types or deferred constants, where we will list the
359 -- info for the full view). If debug flag A is set, then all
360 -- entities are listed
362 if (Comes_From_Source
(E
)
363 and then not Is_Incomplete_Or_Private_Type
(E
)
364 and then not (Ekind
(E
) = E_Constant
365 and then Present
(Full_View
(E
))))
366 or else Debug_Flag_AA
372 Ekind
(E
) = E_Entry_Family
374 Ekind
(E
) = E_Subprogram_Type
376 if List_Representation_Info_Mechanisms
then
380 elsif Is_Record_Type
(E
) then
381 if List_Representation_Info
>= 1 then
382 List_Record_Info
(E
);
385 elsif Is_Array_Type
(E
) then
386 if List_Representation_Info
>= 1 then
390 elsif Is_Type
(E
) then
391 if List_Representation_Info
>= 2 then
395 elsif Ekind
(E
) = E_Variable
397 Ekind
(E
) = E_Constant
399 Ekind
(E
) = E_Loop_Parameter
403 if List_Representation_Info
>= 2 then
404 List_Object_Info
(E
);
408 -- Recurse into nested package, but not if they are package
409 -- renamings (in particular renamings of the enclosing package,
410 -- as for some Java bindings and for generic instances).
412 if Ekind
(E
) = E_Package
then
413 if No
(Renamed_Object
(E
)) then
417 -- Recurse into bodies
419 elsif Ekind
(E
) = E_Protected_Type
421 Ekind
(E
) = E_Task_Type
423 Ekind
(E
) = E_Subprogram_Body
425 Ekind
(E
) = E_Package_Body
427 Ekind
(E
) = E_Task_Body
429 Ekind
(E
) = E_Protected_Body
433 -- Recurse into blocks
435 elsif Ekind
(E
) = E_Block
then
440 E
:= Next_Entity
(E
);
443 -- For a package body, the entities of the visible subprograms are
444 -- declared in the corresponding spec. Iterate over its entities in
445 -- order to handle properly the subprogram bodies. Skip bodies in
446 -- subunits, which are listed independently.
448 if Ekind
(Ent
) = E_Package_Body
449 and then Present
(Corresponding_Spec
(Find_Declaration
(Ent
)))
451 E
:= First_Entity
(Corresponding_Spec
(Find_Declaration
(Ent
)));
453 while Present
(E
) loop
456 Nkind
(Find_Declaration
(E
)) = N_Subprogram_Declaration
458 Body_E
:= Corresponding_Body
(Find_Declaration
(E
));
462 Nkind
(Parent
(Find_Declaration
(Body_E
))) /= N_Subunit
464 List_Entities
(Body_E
);
474 -------------------------
475 -- List_GCC_Expression --
476 -------------------------
478 procedure List_GCC_Expression
(U
: Node_Ref_Or_Val
) is
480 procedure Print_Expr
(Val
: Node_Ref_Or_Val
);
481 -- Internal recursive procedure to print expression
487 procedure Print_Expr
(Val
: Node_Ref_Or_Val
) is
490 UI_Write
(Val
, Decimal
);
494 Node
: Exp_Node
renames Rep_Table
.Table
(-UI_To_Int
(Val
));
496 procedure Binop
(S
: String);
497 -- Output text for binary operator with S being operator name
503 procedure Binop
(S
: String) is
506 Print_Expr
(Node
.Op1
);
508 Print_Expr
(Node
.Op2
);
512 -- Start of processing for Print_Expr
518 Print_Expr
(Node
.Op1
);
519 Write_Str
(" then ");
520 Print_Expr
(Node
.Op2
);
521 Write_Str
(" else ");
522 Print_Expr
(Node
.Op3
);
534 when Trunc_Div_Expr
=>
537 when Ceil_Div_Expr
=>
540 when Floor_Div_Expr
=>
543 when Trunc_Mod_Expr
=>
546 when Floor_Mod_Expr
=>
549 when Ceil_Mod_Expr
=>
552 when Exact_Div_Expr
=>
557 Print_Expr
(Node
.Op1
);
567 Print_Expr
(Node
.Op1
);
569 when Truth_Andif_Expr
=>
572 when Truth_Orif_Expr
=>
575 when Truth_And_Expr
=>
578 when Truth_Or_Expr
=>
581 when Truth_Xor_Expr
=>
584 when Truth_Not_Expr
=>
586 Print_Expr
(Node
.Op1
);
618 -- Start of processing for List_GCC_Expression
626 end List_GCC_Expression
;
628 ---------------------
629 -- List_Mechanisms --
630 ---------------------
632 procedure List_Mechanisms
(Ent
: Entity_Id
) is
641 Write_Str
("function ");
644 Write_Str
("operator ");
647 Write_Str
("procedure ");
649 when E_Subprogram_Type
=>
652 when E_Entry | E_Entry_Family
=>
653 Write_Str
("entry ");
659 Get_Unqualified_Decoded_Name_String
(Chars
(Ent
));
660 Write_Str
(Name_Buffer
(1 .. Name_Len
));
661 Write_Str
(" declared at ");
662 Write_Location
(Sloc
(Ent
));
665 Write_Str
(" convention : ");
667 case Convention
(Ent
) is
668 when Convention_Ada
=> Write_Line
("Ada");
669 when Convention_Intrinsic
=> Write_Line
("InLineinsic");
670 when Convention_Entry
=> Write_Line
("Entry");
671 when Convention_Protected
=> Write_Line
("Protected");
672 when Convention_Assembler
=> Write_Line
("Assembler");
673 when Convention_C
=> Write_Line
("C");
674 when Convention_CIL
=> Write_Line
("CIL");
675 when Convention_COBOL
=> Write_Line
("COBOL");
676 when Convention_CPP
=> Write_Line
("C++");
677 when Convention_Fortran
=> Write_Line
("Fortran");
678 when Convention_Java
=> Write_Line
("Java");
679 when Convention_Stdcall
=> Write_Line
("Stdcall");
680 when Convention_Stubbed
=> Write_Line
("Stubbed");
683 -- Find max length of formal name
686 Form
:= First_Formal
(Ent
);
687 while Present
(Form
) loop
688 Get_Unqualified_Decoded_Name_String
(Chars
(Form
));
690 if Name_Len
> Plen
then
697 -- Output formals and mechanisms
699 Form
:= First_Formal
(Ent
);
700 while Present
(Form
) loop
701 Get_Unqualified_Decoded_Name_String
(Chars
(Form
));
703 while Name_Len
<= Plen
loop
704 Name_Len
:= Name_Len
+ 1;
705 Name_Buffer
(Name_Len
) := ' ';
709 Write_Str
(Name_Buffer
(1 .. Plen
+ 1));
710 Write_Str
(": passed by ");
712 Write_Mechanism
(Mechanism
(Form
));
717 if Etype
(Ent
) /= Standard_Void_Type
then
718 Write_Str
(" returns by ");
719 Write_Mechanism
(Mechanism
(Ent
));
728 procedure List_Name
(Ent
: Entity_Id
) is
730 if not Is_Compilation_Unit
(Scope
(Ent
)) then
731 List_Name
(Scope
(Ent
));
735 Get_Unqualified_Decoded_Name_String
(Chars
(Ent
));
736 Set_Casing
(Unit_Casing
);
737 Write_Str
(Name_Buffer
(1 .. Name_Len
));
740 ---------------------
741 -- List_Object_Info --
742 ---------------------
744 procedure List_Object_Info
(Ent
: Entity_Id
) is
750 Write_Str
("'Size use ");
751 Write_Val
(Esize
(Ent
));
756 Write_Str
("'Alignment use ");
757 Write_Val
(Alignment
(Ent
));
759 end List_Object_Info
;
761 ----------------------
762 -- List_Record_Info --
763 ----------------------
765 procedure List_Record_Info
(Ent
: Entity_Id
) is
770 Max_Name_Length
: Natural;
771 Max_Suni_Length
: Natural;
775 List_Type_Info
(Ent
);
779 Write_Line
(" use record");
781 -- First loop finds out max line length and max starting position
782 -- length, for the purpose of lining things up nicely.
784 Max_Name_Length
:= 0;
785 Max_Suni_Length
:= 0;
787 Comp
:= First_Component_Or_Discriminant
(Ent
);
788 while Present
(Comp
) loop
789 Get_Decoded_Name_String
(Chars
(Comp
));
790 Max_Name_Length
:= Natural'Max (Max_Name_Length
, Name_Len
);
792 Cfbit
:= Component_Bit_Offset
(Comp
);
794 if Rep_Not_Constant
(Cfbit
) then
795 UI_Image_Length
:= 2;
798 -- Complete annotation in case not done
800 Set_Normalized_Position
(Comp
, Cfbit
/ SSU
);
801 Set_Normalized_First_Bit
(Comp
, Cfbit
mod SSU
);
803 Sunit
:= Cfbit
/ SSU
;
807 -- If the record is not packed, then we know that all fields whose
808 -- position is not specified have a starting normalized bit position
811 if Unknown_Normalized_First_Bit
(Comp
)
812 and then not Is_Packed
(Ent
)
814 Set_Normalized_First_Bit
(Comp
, Uint_0
);
818 Natural'Max (Max_Suni_Length
, UI_Image_Length
);
820 Next_Component_Or_Discriminant
(Comp
);
823 -- Second loop does actual output based on those values
825 Comp
:= First_Component_Or_Discriminant
(Ent
);
826 while Present
(Comp
) loop
828 Esiz
: constant Uint
:= Esize
(Comp
);
829 Bofs
: constant Uint
:= Component_Bit_Offset
(Comp
);
830 Npos
: constant Uint
:= Normalized_Position
(Comp
);
831 Fbit
: constant Uint
:= Normalized_First_Bit
(Comp
);
836 Get_Decoded_Name_String
(Chars
(Comp
));
837 Set_Casing
(Unit_Casing
);
838 Write_Str
(Name_Buffer
(1 .. Name_Len
));
840 for J
in 1 .. Max_Name_Length
- Name_Len
loop
846 if Known_Static_Normalized_Position
(Comp
) then
848 Spaces
(Max_Suni_Length
- UI_Image_Length
);
849 Write_Str
(UI_Image_Buffer
(1 .. UI_Image_Length
));
851 elsif Known_Component_Bit_Offset
(Comp
)
852 and then List_Representation_Info
= 3
854 Spaces
(Max_Suni_Length
- 2);
855 Write_Str
("bit offset");
856 Write_Val
(Bofs
, Paren
=> True);
857 Write_Str
(" size in bits = ");
858 Write_Val
(Esiz
, Paren
=> True);
862 elsif Known_Normalized_Position
(Comp
)
863 and then List_Representation_Info
= 3
865 Spaces
(Max_Suni_Length
- 2);
869 -- For the packed case, we don't know the bit positions if we
870 -- don't know the starting position!
872 if Is_Packed
(Ent
) then
873 Write_Line
("?? range ? .. ??;");
876 -- Otherwise we can continue
883 Write_Str
(" range ");
887 -- Allowing Uint_0 here is a kludge, really this should be a
888 -- fine Esize value but currently it means unknown, except that
889 -- we know after gigi has back annotated that a size of zero is
890 -- real, since otherwise gigi back annotates using No_Uint as
891 -- the value to indicate unknown).
893 if (Esize
(Comp
) = Uint_0
or else Known_Static_Esize
(Comp
))
894 and then Known_Static_Normalized_First_Bit
(Comp
)
896 Lbit
:= Fbit
+ Esiz
- 1;
904 -- The test for Esize (Comp) not being Uint_0 here is a kludge.
905 -- Officially a value of zero for Esize means unknown, but here
906 -- we use the fact that we know that gigi annotates Esize with
907 -- No_Uint, not Uint_0. Really everyone should use No_Uint???
909 elsif List_Representation_Info
< 3
910 or else (Esize
(Comp
) /= Uint_0
and then Unknown_Esize
(Comp
))
914 -- List_Representation >= 3 and Known_Esize (Comp)
917 Write_Val
(Esiz
, Paren
=> True);
919 -- If in front end layout mode, then dynamic size is stored
920 -- in storage units, so renormalize for output
922 if not Back_End_Layout
then
927 -- Add appropriate first bit offset
937 Write_Int
(UI_To_Int
(Fbit
) - 1);
945 Next_Component_Or_Discriminant
(Comp
);
948 Write_Line
("end record;");
949 end List_Record_Info
;
955 procedure List_Rep_Info
is
959 if List_Representation_Info
/= 0
960 or else List_Representation_Info_Mechanisms
962 for U
in Main_Unit
.. Last_Unit
loop
963 if In_Extended_Main_Source_Unit
(Cunit_Entity
(U
)) then
965 -- Normal case, list to standard output
967 if not List_Representation_Info_To_File
then
968 Unit_Casing
:= Identifier_Casing
(Source_Index
(U
));
970 Write_Str
("Representation information for unit ");
971 Write_Unit_Name
(Unit_Name
(U
));
975 for J
in 1 .. Col
- 1 loop
980 List_Entities
(Cunit_Entity
(U
));
982 -- List representation information to file
985 Create_Repinfo_File_Access
.all
986 (Get_Name_String
(File_Name
(Source_Index
(U
))));
987 Set_Special_Output
(Write_Info_Line
'Access);
988 List_Entities
(Cunit_Entity
(U
));
989 Set_Special_Output
(null);
990 Close_Repinfo_File_Access
.all;
1001 procedure List_Type_Info
(Ent
: Entity_Id
) is
1005 -- Do not list size info for unconstrained arrays, not meaningful
1007 if Is_Array_Type
(Ent
) and then not Is_Constrained
(Ent
) then
1011 -- If Esize and RM_Size are the same and known, list as Size. This
1012 -- is a common case, which we may as well list in simple form.
1014 if Esize
(Ent
) = RM_Size
(Ent
) then
1017 Write_Str
("'Size use ");
1018 Write_Val
(Esize
(Ent
));
1021 -- For now, temporary case, to be removed when gigi properly back
1022 -- annotates RM_Size, if RM_Size is not set, then list Esize as Size.
1023 -- This avoids odd Object_Size output till we fix things???
1025 elsif Unknown_RM_Size
(Ent
) then
1028 Write_Str
("'Size use ");
1029 Write_Val
(Esize
(Ent
));
1032 -- Otherwise list size values separately if they are set
1037 Write_Str
("'Object_Size use ");
1038 Write_Val
(Esize
(Ent
));
1041 -- Note on following check: The RM_Size of a discrete type can
1042 -- legitimately be set to zero, so a special check is needed.
1046 Write_Str
("'Value_Size use ");
1047 Write_Val
(RM_Size
(Ent
));
1054 Write_Str
("'Alignment use ");
1055 Write_Val
(Alignment
(Ent
));
1058 -- Special stuff for fixed-point
1060 if Is_Fixed_Point_Type
(Ent
) then
1062 -- Write small (always a static constant)
1066 Write_Str
("'Small use ");
1067 UR_Write
(Small_Value
(Ent
));
1070 -- Write range if static
1073 R
: constant Node_Id
:= Scalar_Range
(Ent
);
1076 if Nkind
(Low_Bound
(R
)) = N_Real_Literal
1078 Nkind
(High_Bound
(R
)) = N_Real_Literal
1082 Write_Str
("'Range use ");
1083 UR_Write
(Realval
(Low_Bound
(R
)));
1085 UR_Write
(Realval
(High_Bound
(R
)));
1092 ----------------------
1093 -- Rep_Not_Constant --
1094 ----------------------
1096 function Rep_Not_Constant
(Val
: Node_Ref_Or_Val
) return Boolean is
1098 if Val
= No_Uint
or else Val
< 0 then
1103 end Rep_Not_Constant
;
1110 (Val
: Node_Ref_Or_Val
;
1111 D
: Discrim_List
) return Uint
1113 function B
(Val
: Boolean) return Uint
;
1114 -- Returns Uint_0 for False, Uint_1 for True
1116 function T
(Val
: Node_Ref_Or_Val
) return Boolean;
1117 -- Returns True for 0, False for any non-zero (i.e. True)
1119 function V
(Val
: Node_Ref_Or_Val
) return Uint
;
1120 -- Internal recursive routine to evaluate tree
1122 function W
(Val
: Uint
) return Word
;
1123 -- Convert Val to Word, assuming Val is always in the Int range. This
1124 -- is a helper function for the evaluation of bitwise expressions like
1125 -- Bit_And_Expr, for which there is no direct support in uintp. Uint
1126 -- values out of the Int range are expected to be seen in such
1127 -- expressions only with overflowing byte sizes around, introducing
1128 -- inherent unreliabilities in computations anyway.
1134 function B
(Val
: Boolean) return Uint
is
1147 function T
(Val
: Node_Ref_Or_Val
) return Boolean is
1160 function V
(Val
: Node_Ref_Or_Val
) return Uint
is
1169 Node
: Exp_Node
renames Rep_Table
.Table
(-UI_To_Int
(Val
));
1174 if T
(Node
.Op1
) then
1175 return V
(Node
.Op2
);
1177 return V
(Node
.Op3
);
1181 return V
(Node
.Op1
) + V
(Node
.Op2
);
1184 return V
(Node
.Op1
) - V
(Node
.Op2
);
1187 return V
(Node
.Op1
) * V
(Node
.Op2
);
1189 when Trunc_Div_Expr
=>
1190 return V
(Node
.Op1
) / V
(Node
.Op2
);
1192 when Ceil_Div_Expr
=>
1195 (V
(Node
.Op1
) / UR_From_Uint
(V
(Node
.Op2
)));
1197 when Floor_Div_Expr
=>
1200 (V
(Node
.Op1
) / UR_From_Uint
(V
(Node
.Op2
)));
1202 when Trunc_Mod_Expr
=>
1203 return V
(Node
.Op1
) rem V
(Node
.Op2
);
1205 when Floor_Mod_Expr
=>
1206 return V
(Node
.Op1
) mod V
(Node
.Op2
);
1208 when Ceil_Mod_Expr
=>
1211 Q
:= UR_Ceiling
(L
/ UR_From_Uint
(R
));
1214 when Exact_Div_Expr
=>
1215 return V
(Node
.Op1
) / V
(Node
.Op2
);
1218 return -V
(Node
.Op1
);
1221 return UI_Min
(V
(Node
.Op1
), V
(Node
.Op2
));
1224 return UI_Max
(V
(Node
.Op1
), V
(Node
.Op2
));
1227 return UI_Abs
(V
(Node
.Op1
));
1229 when Truth_Andif_Expr
=>
1230 return B
(T
(Node
.Op1
) and then T
(Node
.Op2
));
1232 when Truth_Orif_Expr
=>
1233 return B
(T
(Node
.Op1
) or else T
(Node
.Op2
));
1235 when Truth_And_Expr
=>
1236 return B
(T
(Node
.Op1
) and then T
(Node
.Op2
));
1238 when Truth_Or_Expr
=>
1239 return B
(T
(Node
.Op1
) or else T
(Node
.Op2
));
1241 when Truth_Xor_Expr
=>
1242 return B
(T
(Node
.Op1
) xor T
(Node
.Op2
));
1244 when Truth_Not_Expr
=>
1245 return B
(not T
(Node
.Op1
));
1247 when Bit_And_Expr
=>
1250 return UI_From_Int
(Int
(W
(L
) and W
(R
)));
1253 return B
(V
(Node
.Op1
) < V
(Node
.Op2
));
1256 return B
(V
(Node
.Op1
) <= V
(Node
.Op2
));
1259 return B
(V
(Node
.Op1
) > V
(Node
.Op2
));
1262 return B
(V
(Node
.Op1
) >= V
(Node
.Op2
));
1265 return B
(V
(Node
.Op1
) = V
(Node
.Op2
));
1268 return B
(V
(Node
.Op1
) /= V
(Node
.Op2
));
1272 Sub
: constant Int
:= UI_To_Int
(Node
.Op1
);
1275 pragma Assert
(Sub
in D
'Range);
1288 -- We use an unchecked conversion to map Int values to their Word
1289 -- bitwise equivalent, which we could not achieve with a normal type
1290 -- conversion for negative Ints. We want bitwise equivalents because W
1291 -- is used as a helper for bit operators like Bit_And_Expr, and can be
1292 -- called for negative Ints in the context of aligning expressions like
1293 -- X+Align & -Align.
1295 function W
(Val
: Uint
) return Word
is
1296 function To_Word
is new Ada
.Unchecked_Conversion
(Int
, Word
);
1298 return To_Word
(UI_To_Int
(Val
));
1301 -- Start of processing for Rep_Value
1304 if Val
= No_Uint
then
1316 procedure Spaces
(N
: Natural) is
1318 for J
in 1 .. N
loop
1327 procedure Tree_Read
is
1329 Rep_Table
.Tree_Read
;
1336 procedure Tree_Write
is
1338 Rep_Table
.Tree_Write
;
1341 ---------------------
1342 -- Write_Info_Line --
1343 ---------------------
1345 procedure Write_Info_Line
(S
: String) is
1347 Write_Repinfo_Line_Access
.all (S
(S
'First .. S
'Last - 1));
1348 end Write_Info_Line
;
1350 ---------------------
1351 -- Write_Mechanism --
1352 ---------------------
1354 procedure Write_Mechanism
(M
: Mechanism_Type
) is
1358 Write_Str
("default");
1364 Write_Str
("reference");
1367 Write_Str
("descriptor");
1370 Write_Str
("descriptor (UBS)");
1373 Write_Str
("descriptor (UBSB)");
1376 Write_Str
("descriptor (UBA)");
1379 Write_Str
("descriptor (S)");
1382 Write_Str
("descriptor (SB)");
1385 Write_Str
("descriptor (A)");
1388 Write_Str
("descriptor (NCA)");
1391 raise Program_Error
;
1393 end Write_Mechanism
;
1399 procedure Write_Val
(Val
: Node_Ref_Or_Val
; Paren
: Boolean := False) is
1401 if Rep_Not_Constant
(Val
) then
1402 if List_Representation_Info
< 3 or else Val
= No_Uint
then
1406 if Back_End_Layout
then
1411 List_GCC_Expression
(Val
);
1414 List_GCC_Expression
(Val
);
1422 Write_Name_Decoded
(Chars
(Get_Dynamic_SO_Entity
(Val
)));
1425 Write_Name_Decoded
(Chars
(Get_Dynamic_SO_Entity
(Val
)));