1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1999-2003 Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Alloc
; use Alloc
;
35 with Atree
; use Atree
;
36 with Casing
; use Casing
;
37 with Debug
; use Debug
;
38 with Einfo
; use Einfo
;
40 with Namet
; use Namet
;
42 with Output
; use Output
;
43 with Sinfo
; use Sinfo
;
44 with Sinput
; use Sinput
;
45 with Snames
; use Snames
;
46 with Stand
; use Stand
;
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.
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,
65 -- so that gigi lays out dynamic size/offset fields using encoded
68 -- A table internal to this unit is used to hold the values of
69 -- back annotated expressions. This table is written out by -gnatt
70 -- and read back in for ASIS processing.
72 -- Node values are stored as Uint values which are the negative of
73 -- the node index in this table. Constants appear as non-negative
76 type Exp_Node
is record
78 Op1
: Node_Ref_Or_Val
;
79 Op2
: Node_Ref_Or_Val
;
80 Op3
: Node_Ref_Or_Val
;
83 package Rep_Table
is new Table
.Table
(
84 Table_Component_Type
=> Exp_Node
,
85 Table_Index_Type
=> Nat
,
87 Table_Initial
=> Alloc
.Rep_Table_Initial
,
88 Table_Increment
=> Alloc
.Rep_Table_Increment
,
89 Table_Name
=> "BE_Rep_Table");
91 --------------------------------------------------------------
92 -- Representation of Front-End Dynamic Size/Offset Entities --
93 --------------------------------------------------------------
95 package Dynamic_SO_Entity_Table
is new Table
.Table
(
96 Table_Component_Type
=> Entity_Id
,
97 Table_Index_Type
=> Nat
,
99 Table_Initial
=> Alloc
.Rep_Table_Initial
,
100 Table_Increment
=> Alloc
.Rep_Table_Increment
,
101 Table_Name
=> "FE_Rep_Table");
103 Unit_Casing
: Casing_Type
;
104 -- Identifier casing for current unit
106 Need_Blank_Line
: Boolean;
107 -- Set True if a blank line is needed before outputting any
108 -- information for the current entity. Set True when a new
109 -- entity is processed, and false when the blank line is output.
111 -----------------------
112 -- Local Subprograms --
113 -----------------------
115 function Back_End_Layout
return Boolean;
116 -- Test for layout mode, True = back end, False = front end. This
117 -- function is used rather than checking the configuration parameter
118 -- because we do not want Repinfo to depend on Targparm (for ASIS)
120 procedure Blank_Line
;
121 -- Called before outputting anything for an entity. Ensures that
122 -- a blank line precedes the output for a particular entity.
124 procedure List_Entities
(Ent
: Entity_Id
);
125 -- This procedure lists the entities associated with the entity E,
126 -- starting with the First_Entity and using the Next_Entity link.
127 -- If a nested package is found, entities within the package are
128 -- recursively processed.
130 procedure List_Name
(Ent
: Entity_Id
);
131 -- List name of entity Ent in appropriate case. The name is listed with
132 -- full qualification up to but not including the compilation unit name.
134 procedure List_Array_Info
(Ent
: Entity_Id
);
135 -- List representation info for array type Ent
137 procedure List_Mechanisms
(Ent
: Entity_Id
);
138 -- List mechanism information for parameters of Ent, which is a
139 -- subprogram, subprogram type, or an entry or entry family.
141 procedure List_Object_Info
(Ent
: Entity_Id
);
142 -- List representation info for object Ent
144 procedure List_Record_Info
(Ent
: Entity_Id
);
145 -- List representation info for record type Ent
147 procedure List_Type_Info
(Ent
: Entity_Id
);
148 -- List type info for type Ent
150 function Rep_Not_Constant
(Val
: Node_Ref_Or_Val
) return Boolean;
151 -- Returns True if Val represents a variable value, and False if it
152 -- represents a value that is fixed at compile time.
154 procedure Spaces
(N
: Natural);
155 -- Output given number of spaces
157 procedure Write_Info_Line
(S
: String);
158 -- Routine to write a line to Repinfo output file. This routine is
159 -- passed as a special output procedure to Output.Set_Special_Output.
160 -- Note that Write_Info_Line is called with an EOL character at the
161 -- end of each line, as per the Output spec, but the internal call
162 -- to the appropriate routine in Osint requires that the end of line
163 -- sequence be stripped off.
165 procedure Write_Mechanism
(M
: Mechanism_Type
);
166 -- Writes symbolic string for mechanism represented by M
168 procedure Write_Val
(Val
: Node_Ref_Or_Val
; Paren
: Boolean := False);
169 -- Given a representation value, write it out. No_Uint values or values
170 -- dependent on discriminants are written as two question marks. If the
171 -- flag Paren is set, then the output is surrounded in parentheses if
172 -- it is other than a simple value.
174 ---------------------
175 -- Back_End_Layout --
176 ---------------------
178 function Back_End_Layout
return Boolean is
180 -- We have back end layout if the back end has made any entries in
181 -- the table of GCC expressions, otherwise we have front end layout.
183 return Rep_Table
.Last
> 0;
190 procedure Blank_Line
is
192 if Need_Blank_Line
then
194 Need_Blank_Line
:= False;
198 ------------------------
199 -- Create_Discrim_Ref --
200 ------------------------
202 function Create_Discrim_Ref
206 N
: constant Uint
:= Discriminant_Number
(Discr
);
210 Rep_Table
.Increment_Last
;
212 Rep_Table
.Table
(T
).Expr
:= Discrim_Val
;
213 Rep_Table
.Table
(T
).Op1
:= N
;
214 Rep_Table
.Table
(T
).Op2
:= No_Uint
;
215 Rep_Table
.Table
(T
).Op3
:= No_Uint
;
216 return UI_From_Int
(-T
);
217 end Create_Discrim_Ref
;
219 ---------------------------
220 -- Create_Dynamic_SO_Ref --
221 ---------------------------
223 function Create_Dynamic_SO_Ref
225 return Dynamic_SO_Ref
230 Dynamic_SO_Entity_Table
.Increment_Last
;
231 T
:= Dynamic_SO_Entity_Table
.Last
;
232 Dynamic_SO_Entity_Table
.Table
(T
) := E
;
233 return UI_From_Int
(-T
);
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
)
250 Rep_Table
.Increment_Last
;
252 Rep_Table
.Table
(T
).Expr
:= Expr
;
253 Rep_Table
.Table
(T
).Op1
:= Op1
;
254 Rep_Table
.Table
(T
).Op2
:= Op2
;
255 Rep_Table
.Table
(T
).Op3
:= Op3
;
257 return UI_From_Int
(-T
);
260 ---------------------------
261 -- Get_Dynamic_SO_Entity --
262 ---------------------------
264 function Get_Dynamic_SO_Entity
269 return Dynamic_SO_Entity_Table
.Table
(-UI_To_Int
(U
));
270 end Get_Dynamic_SO_Entity
;
272 -----------------------
273 -- Is_Dynamic_SO_Ref --
274 -----------------------
276 function Is_Dynamic_SO_Ref
(U
: SO_Ref
) return Boolean is
279 end Is_Dynamic_SO_Ref
;
281 ----------------------
282 -- Is_Static_SO_Ref --
283 ----------------------
285 function Is_Static_SO_Ref
(U
: SO_Ref
) return Boolean is
288 end Is_Static_SO_Ref
;
294 procedure lgx
(U
: Node_Ref_Or_Val
) is
296 List_GCC_Expression
(U
);
300 ----------------------
301 -- List_Array_Info --
302 ----------------------
304 procedure List_Array_Info
(Ent
: Entity_Id
) is
306 List_Type_Info
(Ent
);
310 Write_Str
("'Component_Size use ");
311 Write_Val
(Component_Size
(Ent
));
319 procedure List_Entities
(Ent
: Entity_Id
) is
323 function Find_Declaration
(E
: Entity_Id
) return Node_Id
;
324 -- Utility to retrieve declaration node for entity in the
325 -- case of package bodies and subprograms.
327 ----------------------
328 -- Find_Declaration --
329 ----------------------
331 function Find_Declaration
(E
: Entity_Id
) return Node_Id
is
337 and then Nkind
(Decl
) /= N_Package_Body
338 and then Nkind
(Decl
) /= N_Subprogram_Declaration
339 and then Nkind
(Decl
) /= N_Subprogram_Body
341 Decl
:= Parent
(Decl
);
345 end Find_Declaration
;
347 -- Start of processing for List_Entities
350 if Present
(Ent
) then
352 -- If entity is a subprogram and we are listing mechanisms,
353 -- then we need to list mechanisms for this entity.
355 if List_Representation_Info_Mechanisms
356 and then (Is_Subprogram
(Ent
)
357 or else Ekind
(Ent
) = E_Entry
358 or else Ekind
(Ent
) = E_Entry_Family
)
360 Need_Blank_Line
:= True;
361 List_Mechanisms
(Ent
);
364 E
:= First_Entity
(Ent
);
365 while Present
(E
) loop
366 Need_Blank_Line
:= True;
368 -- We list entities that come from source (excluding private
369 -- or incomplete types or deferred constants, where we will
370 -- list the info for the full view). If debug flag A is set,
371 -- then all entities are listed
373 if (Comes_From_Source
(E
)
374 and then not Is_Incomplete_Or_Private_Type
(E
)
375 and then not (Ekind
(E
) = E_Constant
376 and then Present
(Full_View
(E
))))
377 or else Debug_Flag_AA
383 Ekind
(E
) = E_Entry_Family
385 Ekind
(E
) = E_Subprogram_Type
387 if List_Representation_Info_Mechanisms
then
391 elsif Is_Record_Type
(E
) then
392 if List_Representation_Info
>= 1 then
393 List_Record_Info
(E
);
396 elsif Is_Array_Type
(E
) then
397 if List_Representation_Info
>= 1 then
401 elsif Is_Type
(E
) then
402 if List_Representation_Info
>= 2 then
406 elsif Ekind
(E
) = E_Variable
408 Ekind
(E
) = E_Constant
410 Ekind
(E
) = E_Loop_Parameter
414 if List_Representation_Info
>= 2 then
415 List_Object_Info
(E
);
420 -- Recurse into nested package, but not if they are
421 -- package renamings (in particular renamings of the
422 -- enclosing package, as for some Java bindings and
423 -- for generic instances).
425 if Ekind
(E
) = E_Package
then
426 if No
(Renamed_Object
(E
)) then
430 -- Recurse into bodies
432 elsif Ekind
(E
) = E_Protected_Type
434 Ekind
(E
) = E_Task_Type
436 Ekind
(E
) = E_Subprogram_Body
438 Ekind
(E
) = E_Package_Body
440 Ekind
(E
) = E_Task_Body
442 Ekind
(E
) = E_Protected_Body
446 -- Recurse into blocks
448 elsif Ekind
(E
) = E_Block
then
453 E
:= Next_Entity
(E
);
456 -- For a package body, the entities of the visible subprograms
457 -- are declared in the corresponding spec. Iterate over its
458 -- entities in order to handle properly the subprogram bodies.
459 -- Skip bodies in subunits, which are listed independently.
461 if Ekind
(Ent
) = E_Package_Body
462 and then Present
(Corresponding_Spec
(Find_Declaration
(Ent
)))
464 E
:= First_Entity
(Corresponding_Spec
(Find_Declaration
(Ent
)));
466 while Present
(E
) loop
469 Nkind
(Find_Declaration
(E
)) = N_Subprogram_Declaration
471 Body_E
:= Corresponding_Body
(Find_Declaration
(E
));
475 Nkind
(Parent
(Find_Declaration
(Body_E
))) /= N_Subunit
477 List_Entities
(Body_E
);
487 -------------------------
488 -- List_GCC_Expression --
489 -------------------------
491 procedure List_GCC_Expression
(U
: Node_Ref_Or_Val
) is
493 procedure Print_Expr
(Val
: Node_Ref_Or_Val
);
494 -- Internal recursive procedure to print expression
500 procedure Print_Expr
(Val
: Node_Ref_Or_Val
) is
503 UI_Write
(Val
, Decimal
);
507 Node
: Exp_Node
renames Rep_Table
.Table
(-UI_To_Int
(Val
));
509 procedure Binop
(S
: String);
510 -- Output text for binary operator with S being operator name
516 procedure Binop
(S
: String) is
519 Print_Expr
(Node
.Op1
);
521 Print_Expr
(Node
.Op2
);
525 -- Start of processing for Print_Expr
531 Print_Expr
(Node
.Op1
);
532 Write_Str
(" then ");
533 Print_Expr
(Node
.Op2
);
534 Write_Str
(" else ");
535 Print_Expr
(Node
.Op3
);
547 when Trunc_Div_Expr
=>
550 when Ceil_Div_Expr
=>
553 when Floor_Div_Expr
=>
556 when Trunc_Mod_Expr
=>
559 when Floor_Mod_Expr
=>
562 when Ceil_Mod_Expr
=>
565 when Exact_Div_Expr
=>
570 Print_Expr
(Node
.Op1
);
580 Print_Expr
(Node
.Op1
);
582 when Truth_Andif_Expr
=>
585 when Truth_Orif_Expr
=>
588 when Truth_And_Expr
=>
591 when Truth_Or_Expr
=>
594 when Truth_Xor_Expr
=>
597 when Truth_Not_Expr
=>
599 Print_Expr
(Node
.Op1
);
628 -- Start of processing for List_GCC_Expression
636 end List_GCC_Expression
;
638 ---------------------
639 -- List_Mechanisms --
640 ---------------------
642 procedure List_Mechanisms
(Ent
: Entity_Id
) is
651 Write_Str
("function ");
654 Write_Str
("operator ");
657 Write_Str
("procedure ");
659 when E_Subprogram_Type
=>
662 when E_Entry | E_Entry_Family
=>
663 Write_Str
("entry ");
669 Get_Unqualified_Decoded_Name_String
(Chars
(Ent
));
670 Write_Str
(Name_Buffer
(1 .. Name_Len
));
671 Write_Str
(" declared at ");
672 Write_Location
(Sloc
(Ent
));
675 Write_Str
(" convention : ");
677 case Convention
(Ent
) is
678 when Convention_Ada
=> Write_Line
("Ada");
679 when Convention_Intrinsic
=> Write_Line
("InLineinsic");
680 when Convention_Entry
=> Write_Line
("Entry");
681 when Convention_Protected
=> Write_Line
("Protected");
682 when Convention_Assembler
=> Write_Line
("Assembler");
683 when Convention_C
=> Write_Line
("C");
684 when Convention_COBOL
=> Write_Line
("COBOL");
685 when Convention_CPP
=> Write_Line
("C++");
686 when Convention_Fortran
=> Write_Line
("Fortran");
687 when Convention_Java
=> Write_Line
("Java");
688 when Convention_Stdcall
=> Write_Line
("Stdcall");
689 when Convention_Stubbed
=> Write_Line
("Stubbed");
692 -- Find max length of formal name
695 Form
:= First_Formal
(Ent
);
696 while Present
(Form
) loop
697 Get_Unqualified_Decoded_Name_String
(Chars
(Form
));
699 if Name_Len
> Plen
then
706 -- Output formals and mechanisms
708 Form
:= First_Formal
(Ent
);
709 while Present
(Form
) loop
710 Get_Unqualified_Decoded_Name_String
(Chars
(Form
));
712 while Name_Len
<= Plen
loop
713 Name_Len
:= Name_Len
+ 1;
714 Name_Buffer
(Name_Len
) := ' ';
718 Write_Str
(Name_Buffer
(1 .. Plen
+ 1));
719 Write_Str
(": passed by ");
721 Write_Mechanism
(Mechanism
(Form
));
726 if Etype
(Ent
) /= Standard_Void_Type
then
727 Write_Str
(" returns by ");
728 Write_Mechanism
(Mechanism
(Ent
));
737 procedure List_Name
(Ent
: Entity_Id
) is
739 if not Is_Compilation_Unit
(Scope
(Ent
)) then
740 List_Name
(Scope
(Ent
));
744 Get_Unqualified_Decoded_Name_String
(Chars
(Ent
));
745 Set_Casing
(Unit_Casing
);
746 Write_Str
(Name_Buffer
(1 .. Name_Len
));
749 ---------------------
750 -- List_Object_Info --
751 ---------------------
753 procedure List_Object_Info
(Ent
: Entity_Id
) is
759 Write_Str
("'Size use ");
760 Write_Val
(Esize
(Ent
));
765 Write_Str
("'Alignment use ");
766 Write_Val
(Alignment
(Ent
));
768 end List_Object_Info
;
770 ----------------------
771 -- List_Record_Info --
772 ----------------------
774 procedure List_Record_Info
(Ent
: Entity_Id
) is
779 Max_Name_Length
: Natural;
780 Max_Suni_Length
: Natural;
784 List_Type_Info
(Ent
);
788 Write_Line
(" use record");
790 -- First loop finds out max line length and max starting position
791 -- length, for the purpose of lining things up nicely.
793 Max_Name_Length
:= 0;
794 Max_Suni_Length
:= 0;
796 Comp
:= First_Entity
(Ent
);
797 while Present
(Comp
) loop
798 if Ekind
(Comp
) = E_Component
799 or else Ekind
(Comp
) = E_Discriminant
801 Get_Decoded_Name_String
(Chars
(Comp
));
802 Max_Name_Length
:= Natural'Max (Max_Name_Length
, Name_Len
);
804 Cfbit
:= Component_Bit_Offset
(Comp
);
806 if Rep_Not_Constant
(Cfbit
) then
807 UI_Image_Length
:= 2;
810 -- Complete annotation in case not done
812 Set_Normalized_Position
(Comp
, Cfbit
/ SSU
);
813 Set_Normalized_First_Bit
(Comp
, Cfbit
mod SSU
);
815 Sunit
:= Cfbit
/ SSU
;
819 -- If the record is not packed, then we know that all
820 -- fields whose position is not specified have a starting
821 -- normalized bit position of zero
823 if Unknown_Normalized_First_Bit
(Comp
)
824 and then not Is_Packed
(Ent
)
826 Set_Normalized_First_Bit
(Comp
, Uint_0
);
830 Natural'Max (Max_Suni_Length
, UI_Image_Length
);
833 Comp
:= Next_Entity
(Comp
);
836 -- Second loop does actual output based on those values
838 Comp
:= First_Entity
(Ent
);
839 while Present
(Comp
) loop
840 if Ekind
(Comp
) = E_Component
841 or else Ekind
(Comp
) = E_Discriminant
844 Esiz
: constant Uint
:= Esize
(Comp
);
845 Bofs
: constant Uint
:= Component_Bit_Offset
(Comp
);
846 Npos
: constant Uint
:= Normalized_Position
(Comp
);
847 Fbit
: constant Uint
:= Normalized_First_Bit
(Comp
);
852 Get_Decoded_Name_String
(Chars
(Comp
));
853 Set_Casing
(Unit_Casing
);
854 Write_Str
(Name_Buffer
(1 .. Name_Len
));
856 for J
in 1 .. Max_Name_Length
- Name_Len
loop
862 if Known_Static_Normalized_Position
(Comp
) then
864 Spaces
(Max_Suni_Length
- UI_Image_Length
);
865 Write_Str
(UI_Image_Buffer
(1 .. UI_Image_Length
));
867 elsif Known_Component_Bit_Offset
(Comp
)
868 and then List_Representation_Info
= 3
870 Spaces
(Max_Suni_Length
- 2);
871 Write_Str
("bit offset");
872 Write_Val
(Bofs
, Paren
=> True);
873 Write_Str
(" size in bits = ");
874 Write_Val
(Esiz
, Paren
=> True);
878 elsif Known_Normalized_Position
(Comp
)
879 and then List_Representation_Info
= 3
881 Spaces
(Max_Suni_Length
- 2);
885 -- For the packed case, we don't know the bit positions
886 -- if we don't know the starting position!
888 if Is_Packed
(Ent
) then
889 Write_Line
("?? range ? .. ??;");
892 -- Otherwise we can continue
899 Write_Str
(" range ");
903 -- Allowing Uint_0 here is a kludge, really this should be
904 -- a fine Esize value but currently it means unknown, except
905 -- that we know after gigi has back annotated that a size of
906 -- zero is real, since otherwise gigi back annotates using
907 -- No_Uint as the value to indicate unknown).
909 if (Esize
(Comp
) = Uint_0
or else Known_Static_Esize
(Comp
))
910 and then Known_Static_Normalized_First_Bit
(Comp
)
912 Lbit
:= Fbit
+ Esiz
- 1;
920 -- The test for Esize (Comp) not being Uint_0 here is a kludge.
921 -- Officially a value of zero for Esize means unknown, but here
922 -- we use the fact that we know that gigi annotates Esize with
923 -- No_Uint, not Uint_0. Really everyone should use No_Uint???
925 elsif List_Representation_Info
< 3
926 or else (Esize
(Comp
) /= Uint_0
and then Unknown_Esize
(Comp
))
930 else -- List_Representation >= 3 and Known_Esize (Comp)
932 Write_Val
(Esiz
, Paren
=> True);
934 -- If in front end layout mode, then dynamic size is
935 -- stored in storage units, so renormalize for output
937 if not Back_End_Layout
then
942 -- Add appropriate first bit offset
952 Write_Int
(UI_To_Int
(Fbit
) - 1);
961 Comp
:= Next_Entity
(Comp
);
964 Write_Line
("end record;");
965 end List_Record_Info
;
971 procedure List_Rep_Info
is
975 if Debug_Flag_AA
then
976 List_Representation_Info
:= 3;
977 List_Representation_Info_Mechanisms
:= True;
980 if List_Representation_Info
/= 0
981 or else List_Representation_Info_Mechanisms
983 for U
in Main_Unit
.. Last_Unit
loop
984 if In_Extended_Main_Source_Unit
(Cunit_Entity
(U
)) then
986 -- Normal case, list to standard output
988 if not List_Representation_Info_To_File
then
989 Unit_Casing
:= Identifier_Casing
(Source_Index
(U
));
991 Write_Str
("Representation information for unit ");
992 Write_Unit_Name
(Unit_Name
(U
));
996 for J
in 1 .. Col
- 1 loop
1001 List_Entities
(Cunit_Entity
(U
));
1003 -- List representation information to file
1006 Creat_Repinfo_File_Access
.all (File_Name
(Source_Index
(U
)));
1007 Set_Special_Output
(Write_Info_Line
'Access);
1008 List_Entities
(Cunit_Entity
(U
));
1009 Set_Special_Output
(null);
1010 Close_Repinfo_File_Access
.all;
1017 --------------------
1018 -- List_Type_Info --
1019 --------------------
1021 procedure List_Type_Info
(Ent
: Entity_Id
) is
1025 -- Do not list size info for unconstrained arrays, not meaningful
1027 if Is_Array_Type
(Ent
) and then not Is_Constrained
(Ent
) then
1031 -- If Esize and RM_Size are the same and known, list as Size. This
1032 -- is a common case, which we may as well list in simple form.
1034 if Esize
(Ent
) = RM_Size
(Ent
) then
1037 Write_Str
("'Size use ");
1038 Write_Val
(Esize
(Ent
));
1041 -- For now, temporary case, to be removed when gigi properly back
1042 -- annotates RM_Size, if RM_Size is not set, then list Esize as
1043 -- Size. This avoids odd Object_Size output till we fix things???
1045 elsif Unknown_RM_Size
(Ent
) then
1048 Write_Str
("'Size use ");
1049 Write_Val
(Esize
(Ent
));
1052 -- Otherwise list size values separately if they are set
1057 Write_Str
("'Object_Size use ");
1058 Write_Val
(Esize
(Ent
));
1061 -- Note on following check: The RM_Size of a discrete type can
1062 -- legitimately be set to zero, so a special check is needed.
1066 Write_Str
("'Value_Size use ");
1067 Write_Val
(RM_Size
(Ent
));
1074 Write_Str
("'Alignment use ");
1075 Write_Val
(Alignment
(Ent
));
1079 ----------------------
1080 -- Rep_Not_Constant --
1081 ----------------------
1083 function Rep_Not_Constant
(Val
: Node_Ref_Or_Val
) return Boolean is
1085 if Val
= No_Uint
or else Val
< 0 then
1090 end Rep_Not_Constant
;
1097 (Val
: Node_Ref_Or_Val
;
1101 function B
(Val
: Boolean) return Uint
;
1102 -- Returns Uint_0 for False, Uint_1 for True
1104 function T
(Val
: Node_Ref_Or_Val
) return Boolean;
1105 -- Returns True for 0, False for any non-zero (i.e. True)
1107 function V
(Val
: Node_Ref_Or_Val
) return Uint
;
1108 -- Internal recursive routine to evaluate tree
1114 function B
(Val
: Boolean) return Uint
is
1127 function T
(Val
: Node_Ref_Or_Val
) return Boolean is
1140 function V
(Val
: Node_Ref_Or_Val
) return Uint
is
1149 Node
: Exp_Node
renames Rep_Table
.Table
(-UI_To_Int
(Val
));
1154 if T
(Node
.Op1
) then
1155 return V
(Node
.Op2
);
1157 return V
(Node
.Op3
);
1161 return V
(Node
.Op1
) + V
(Node
.Op2
);
1164 return V
(Node
.Op1
) - V
(Node
.Op2
);
1167 return V
(Node
.Op1
) * V
(Node
.Op2
);
1169 when Trunc_Div_Expr
=>
1170 return V
(Node
.Op1
) / V
(Node
.Op2
);
1172 when Ceil_Div_Expr
=>
1175 (V
(Node
.Op1
) / UR_From_Uint
(V
(Node
.Op2
)));
1177 when Floor_Div_Expr
=>
1180 (V
(Node
.Op1
) / UR_From_Uint
(V
(Node
.Op2
)));
1182 when Trunc_Mod_Expr
=>
1183 return V
(Node
.Op1
) rem V
(Node
.Op2
);
1185 when Floor_Mod_Expr
=>
1186 return V
(Node
.Op1
) mod V
(Node
.Op2
);
1188 when Ceil_Mod_Expr
=>
1191 Q
:= UR_Ceiling
(L
/ UR_From_Uint
(R
));
1194 when Exact_Div_Expr
=>
1195 return V
(Node
.Op1
) / V
(Node
.Op2
);
1198 return -V
(Node
.Op1
);
1201 return UI_Min
(V
(Node
.Op1
), V
(Node
.Op2
));
1204 return UI_Max
(V
(Node
.Op1
), V
(Node
.Op2
));
1207 return UI_Abs
(V
(Node
.Op1
));
1209 when Truth_Andif_Expr
=>
1210 return B
(T
(Node
.Op1
) and then T
(Node
.Op2
));
1212 when Truth_Orif_Expr
=>
1213 return B
(T
(Node
.Op1
) or else T
(Node
.Op2
));
1215 when Truth_And_Expr
=>
1216 return B
(T
(Node
.Op1
) and T
(Node
.Op2
));
1218 when Truth_Or_Expr
=>
1219 return B
(T
(Node
.Op1
) or T
(Node
.Op2
));
1221 when Truth_Xor_Expr
=>
1222 return B
(T
(Node
.Op1
) xor T
(Node
.Op2
));
1224 when Truth_Not_Expr
=>
1225 return B
(not T
(Node
.Op1
));
1228 return B
(V
(Node
.Op1
) < V
(Node
.Op2
));
1231 return B
(V
(Node
.Op1
) <= V
(Node
.Op2
));
1234 return B
(V
(Node
.Op1
) > V
(Node
.Op2
));
1237 return B
(V
(Node
.Op1
) >= V
(Node
.Op2
));
1240 return B
(V
(Node
.Op1
) = V
(Node
.Op2
));
1243 return B
(V
(Node
.Op1
) /= V
(Node
.Op2
));
1247 Sub
: constant Int
:= UI_To_Int
(Node
.Op1
);
1250 pragma Assert
(Sub
in D
'Range);
1259 -- Start of processing for Rep_Value
1262 if Val
= No_Uint
then
1274 procedure Spaces
(N
: Natural) is
1276 for J
in 1 .. N
loop
1285 procedure Tree_Read
is
1287 Rep_Table
.Tree_Read
;
1294 procedure Tree_Write
is
1296 Rep_Table
.Tree_Write
;
1299 ---------------------
1300 -- Write_Info_Line --
1301 ---------------------
1303 procedure Write_Info_Line
(S
: String) is
1305 Write_Repinfo_Line_Access
.all (S
(S
'First .. S
'Last - 1));
1306 end Write_Info_Line
;
1308 ---------------------
1309 -- Write_Mechanism --
1310 ---------------------
1312 procedure Write_Mechanism
(M
: Mechanism_Type
) is
1316 Write_Str
("default");
1322 Write_Str
("reference");
1325 Write_Str
("descriptor");
1328 Write_Str
("descriptor (UBS)");
1331 Write_Str
("descriptor (UBSB)");
1334 Write_Str
("descriptor (UBA)");
1337 Write_Str
("descriptor (S)");
1340 Write_Str
("descriptor (SB)");
1343 Write_Str
("descriptor (A)");
1346 Write_Str
("descriptor (NCA)");
1349 raise Program_Error
;
1351 end Write_Mechanism
;
1357 procedure Write_Val
(Val
: Node_Ref_Or_Val
; Paren
: Boolean := False) is
1359 if Rep_Not_Constant
(Val
) then
1360 if List_Representation_Info
< 3 or else Val
= No_Uint
then
1364 if Back_End_Layout
then
1369 List_GCC_Expression
(Val
);
1372 List_GCC_Expression
(Val
);
1380 Write_Name_Decoded
(Chars
(Get_Dynamic_SO_Entity
(Val
)));
1383 Write_Name_Decoded
(Chars
(Get_Dynamic_SO_Entity
(Val
)));