1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1999-2014, 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
;
39 with Nlists
; use Nlists
;
41 with Output
; use Output
;
42 with Sem_Aux
; use Sem_Aux
;
43 with Sinfo
; use Sinfo
;
44 with Sinput
; use Sinput
;
45 with Snames
; use Snames
;
46 with Stand
; use Stand
;
47 with Stringt
; use Stringt
;
48 with Table
; use Table
;
49 with Uname
; use Uname
;
50 with Urealp
; use Urealp
;
52 with Ada
.Unchecked_Conversion
;
54 package body Repinfo
is
57 -- Value for Storage_Unit, we do not want to get this from TTypes, since
58 -- this introduces problematic dependencies in ASIS, and in any case this
59 -- value is assumed to be 8 for the implementation of the DDA.
61 -- This is wrong for AAMP???
63 ---------------------------------------
64 -- Representation of gcc Expressions --
65 ---------------------------------------
67 -- This table is used only if Frontend_Layout_On_Target is False, so gigi
68 -- lays out dynamic size/offset fields using encoded gcc expressions.
70 -- A table internal to this unit is used to hold the values of back
71 -- annotated expressions. This table is written out by -gnatt and read
72 -- back in for ASIS processing.
74 -- Node values are stored as Uint values using the negative of the node
75 -- index in this table. Constants appear as non-negative Uint values.
77 type Exp_Node
is record
79 Op1
: Node_Ref_Or_Val
;
80 Op2
: Node_Ref_Or_Val
;
81 Op3
: Node_Ref_Or_Val
;
84 -- The following representation clause ensures that the above record
85 -- has no holes. We do this so that when instances of this record are
86 -- written by Tree_Gen, we do not write uninitialized values to the file.
88 for Exp_Node
use record
89 Expr
at 0 range 0 .. 31;
90 Op1
at 4 range 0 .. 31;
91 Op2
at 8 range 0 .. 31;
92 Op3
at 12 range 0 .. 31;
95 for Exp_Node
'Size use 16 * 8;
96 -- This ensures that we did not leave out any fields
98 package Rep_Table
is new Table
.Table
(
99 Table_Component_Type
=> Exp_Node
,
100 Table_Index_Type
=> Nat
,
101 Table_Low_Bound
=> 1,
102 Table_Initial
=> Alloc
.Rep_Table_Initial
,
103 Table_Increment
=> Alloc
.Rep_Table_Increment
,
104 Table_Name
=> "BE_Rep_Table");
106 --------------------------------------------------------------
107 -- Representation of Front-End Dynamic Size/Offset Entities --
108 --------------------------------------------------------------
110 package Dynamic_SO_Entity_Table
is new Table
.Table
(
111 Table_Component_Type
=> Entity_Id
,
112 Table_Index_Type
=> Nat
,
113 Table_Low_Bound
=> 1,
114 Table_Initial
=> Alloc
.Rep_Table_Initial
,
115 Table_Increment
=> Alloc
.Rep_Table_Increment
,
116 Table_Name
=> "FE_Rep_Table");
118 Unit_Casing
: Casing_Type
;
119 -- Identifier casing for current unit. This is set by List_Rep_Info for
120 -- each unit, before calling subprograms which may read it.
122 Need_Blank_Line
: Boolean;
123 -- Set True if a blank line is needed before outputting any information for
124 -- the current entity. Set True when a new entity is processed, and false
125 -- when the blank line is output.
127 -----------------------
128 -- Local Subprograms --
129 -----------------------
131 function Back_End_Layout
return Boolean;
132 -- Test for layout mode, True = back end, False = front end. This function
133 -- is used rather than checking the configuration parameter because we do
134 -- not want Repinfo to depend on Targparm (for ASIS)
136 procedure Blank_Line
;
137 -- Called before outputting anything for an entity. Ensures that
138 -- a blank line precedes the output for a particular entity.
140 procedure List_Entities
(Ent
: Entity_Id
; Bytes_Big_Endian
: Boolean);
141 -- This procedure lists the entities associated with the entity E, starting
142 -- with the First_Entity and using the Next_Entity link. If a nested
143 -- package is found, entities within the package are recursively processed.
145 procedure List_Name
(Ent
: Entity_Id
);
146 -- List name of entity Ent in appropriate case. The name is listed with
147 -- full qualification up to but not including the compilation unit name.
149 procedure List_Array_Info
(Ent
: Entity_Id
; Bytes_Big_Endian
: Boolean);
150 -- List representation info for array type Ent
152 procedure List_Linker_Section
(Ent
: Entity_Id
);
153 -- List linker section for Ent (caller has checked that Ent is an entity
154 -- for which the Linker_Section_Pragma field is defined).
156 procedure List_Mechanisms
(Ent
: Entity_Id
);
157 -- List mechanism information for parameters of Ent, which is subprogram,
158 -- subprogram type, or an entry or entry family.
160 procedure List_Object_Info
(Ent
: Entity_Id
);
161 -- List representation info for object Ent
163 procedure List_Record_Info
(Ent
: Entity_Id
; Bytes_Big_Endian
: Boolean);
164 -- List representation info for record type Ent
166 procedure List_Scalar_Storage_Order
168 Bytes_Big_Endian
: Boolean);
169 -- List scalar storage order information for record or array type Ent.
170 -- Also includes bit order information for record types, if necessary.
172 procedure List_Type_Info
(Ent
: Entity_Id
);
173 -- List type info for type Ent
175 function Rep_Not_Constant
(Val
: Node_Ref_Or_Val
) return Boolean;
176 -- Returns True if Val represents a variable value, and False if it
177 -- represents a value that is fixed at compile time.
179 procedure Spaces
(N
: Natural);
180 -- Output given number of spaces
182 procedure Write_Info_Line
(S
: String);
183 -- Routine to write a line to Repinfo output file. This routine is passed
184 -- as a special output procedure to Output.Set_Special_Output. Note that
185 -- Write_Info_Line is called with an EOL character at the end of each line,
186 -- as per the Output spec, but the internal call to the appropriate routine
187 -- in Osint requires that the end of line sequence be stripped off.
189 procedure Write_Mechanism
(M
: Mechanism_Type
);
190 -- Writes symbolic string for mechanism represented by M
192 procedure Write_Val
(Val
: Node_Ref_Or_Val
; Paren
: Boolean := False);
193 -- Given a representation value, write it out. No_Uint values or values
194 -- dependent on discriminants are written as two question marks. If the
195 -- flag Paren is set, then the output is surrounded in parentheses if it is
196 -- other than a simple value.
198 ---------------------
199 -- Back_End_Layout --
200 ---------------------
202 function Back_End_Layout
return Boolean is
204 -- We have back end layout if the back end has made any entries in the
205 -- table of GCC expressions, otherwise we have front end layout.
207 return Rep_Table
.Last
> 0;
214 procedure Blank_Line
is
216 if Need_Blank_Line
then
218 Need_Blank_Line
:= False;
222 ------------------------
223 -- Create_Discrim_Ref --
224 ------------------------
226 function Create_Discrim_Ref
(Discr
: Entity_Id
) return Node_Ref
is
229 (Expr
=> Discrim_Val
,
230 Op1
=> Discriminant_Number
(Discr
));
231 end Create_Discrim_Ref
;
233 ---------------------------
234 -- Create_Dynamic_SO_Ref --
235 ---------------------------
237 function Create_Dynamic_SO_Ref
(E
: Entity_Id
) return Dynamic_SO_Ref
is
239 Dynamic_SO_Entity_Table
.Append
(E
);
240 return UI_From_Int
(-Dynamic_SO_Entity_Table
.Last
);
241 end Create_Dynamic_SO_Ref
;
249 Op1
: Node_Ref_Or_Val
;
250 Op2
: Node_Ref_Or_Val
:= No_Uint
;
251 Op3
: Node_Ref_Or_Val
:= No_Uint
) return Node_Ref
259 return UI_From_Int
(-Rep_Table
.Last
);
262 ---------------------------
263 -- Get_Dynamic_SO_Entity --
264 ---------------------------
266 function Get_Dynamic_SO_Entity
(U
: Dynamic_SO_Ref
) return Entity_Id
is
268 return Dynamic_SO_Entity_Table
.Table
(-UI_To_Int
(U
));
269 end Get_Dynamic_SO_Entity
;
271 -----------------------
272 -- Is_Dynamic_SO_Ref --
273 -----------------------
275 function Is_Dynamic_SO_Ref
(U
: SO_Ref
) return Boolean is
278 end Is_Dynamic_SO_Ref
;
280 ----------------------
281 -- Is_Static_SO_Ref --
282 ----------------------
284 function Is_Static_SO_Ref
(U
: SO_Ref
) return Boolean is
287 end Is_Static_SO_Ref
;
293 procedure lgx
(U
: Node_Ref_Or_Val
) is
295 List_GCC_Expression
(U
);
299 ----------------------
300 -- List_Array_Info --
301 ----------------------
303 procedure List_Array_Info
(Ent
: Entity_Id
; Bytes_Big_Endian
: Boolean) is
305 List_Type_Info
(Ent
);
308 Write_Str
("'Component_Size use ");
309 Write_Val
(Component_Size
(Ent
));
312 List_Scalar_Storage_Order
(Ent
, Bytes_Big_Endian
);
319 procedure List_Entities
(Ent
: Entity_Id
; Bytes_Big_Endian
: Boolean) 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 -- List entity if we have one, and it is not a renaming declaration.
351 -- For renamings, we don't get proper information, and really it makes
352 -- sense to restrict the output to the renamed entity.
355 and then Nkind
(Declaration_Node
(Ent
)) not in N_Renaming_Declaration
357 -- If entity is a subprogram and we are listing mechanisms,
358 -- then we need to list mechanisms for this entity.
360 if List_Representation_Info_Mechanisms
361 and then (Is_Subprogram
(Ent
)
362 or else Ekind
(Ent
) = E_Entry
363 or else Ekind
(Ent
) = E_Entry_Family
)
365 Need_Blank_Line
:= True;
366 List_Mechanisms
(Ent
);
369 E
:= First_Entity
(Ent
);
370 while Present
(E
) loop
371 Need_Blank_Line
:= True;
373 -- We list entities that come from source (excluding private or
374 -- incomplete types or deferred constants, where we will list the
375 -- info for the full view). If debug flag A is set, then all
376 -- entities are listed
378 if (Comes_From_Source
(E
)
379 and then not Is_Incomplete_Or_Private_Type
(E
)
380 and then not (Ekind
(E
) = E_Constant
381 and then Present
(Full_View
(E
))))
382 or else Debug_Flag_AA
384 if Is_Subprogram
(E
) then
385 List_Linker_Section
(E
);
387 if List_Representation_Info_Mechanisms
then
391 elsif Ekind_In
(E
, E_Entry
,
395 if List_Representation_Info_Mechanisms
then
399 elsif Is_Record_Type
(E
) then
400 if List_Representation_Info
>= 1 then
401 List_Record_Info
(E
, Bytes_Big_Endian
);
404 List_Linker_Section
(E
);
406 elsif Is_Array_Type
(E
) then
407 if List_Representation_Info
>= 1 then
408 List_Array_Info
(E
, Bytes_Big_Endian
);
411 List_Linker_Section
(E
);
413 elsif Is_Type
(E
) then
414 if List_Representation_Info
>= 2 then
416 List_Linker_Section
(E
);
419 elsif Ekind_In
(E
, E_Variable
, E_Constant
) then
420 if List_Representation_Info
>= 2 then
421 List_Object_Info
(E
);
422 List_Linker_Section
(E
);
425 elsif Ekind
(E
) = E_Loop_Parameter
or else Is_Formal
(E
) then
426 if List_Representation_Info
>= 2 then
427 List_Object_Info
(E
);
431 -- Recurse into nested package, but not if they are package
432 -- renamings (in particular renamings of the enclosing package,
433 -- as for some Java bindings and for generic instances).
435 if Ekind
(E
) = E_Package
then
436 if No
(Renamed_Object
(E
)) then
437 List_Entities
(E
, Bytes_Big_Endian
);
440 -- Recurse into bodies
442 elsif Ekind_In
(E
, E_Protected_Type
,
449 List_Entities
(E
, Bytes_Big_Endian
);
451 -- Recurse into blocks
453 elsif Ekind
(E
) = E_Block
then
454 List_Entities
(E
, Bytes_Big_Endian
);
458 E
:= Next_Entity
(E
);
461 -- For a package body, the entities of the visible subprograms are
462 -- declared in the corresponding spec. Iterate over its entities in
463 -- order to handle properly the subprogram bodies. Skip bodies in
464 -- subunits, which are listed independently.
466 if Ekind
(Ent
) = E_Package_Body
467 and then Present
(Corresponding_Spec
(Find_Declaration
(Ent
)))
469 E
:= First_Entity
(Corresponding_Spec
(Find_Declaration
(Ent
)));
470 while Present
(E
) loop
473 Nkind
(Find_Declaration
(E
)) = N_Subprogram_Declaration
475 Body_E
:= Corresponding_Body
(Find_Declaration
(E
));
479 Nkind
(Parent
(Find_Declaration
(Body_E
))) /= N_Subunit
481 List_Entities
(Body_E
, Bytes_Big_Endian
);
491 -------------------------
492 -- List_GCC_Expression --
493 -------------------------
495 procedure List_GCC_Expression
(U
: Node_Ref_Or_Val
) is
497 procedure Print_Expr
(Val
: Node_Ref_Or_Val
);
498 -- Internal recursive procedure to print expression
504 procedure Print_Expr
(Val
: Node_Ref_Or_Val
) is
507 UI_Write
(Val
, Decimal
);
511 Node
: Exp_Node
renames Rep_Table
.Table
(-UI_To_Int
(Val
));
513 procedure Binop
(S
: String);
514 -- Output text for binary operator with S being operator name
520 procedure Binop
(S
: String) is
523 Print_Expr
(Node
.Op1
);
525 Print_Expr
(Node
.Op2
);
529 -- Start of processing for Print_Expr
535 Print_Expr
(Node
.Op1
);
536 Write_Str
(" then ");
537 Print_Expr
(Node
.Op2
);
538 Write_Str
(" else ");
539 Print_Expr
(Node
.Op3
);
551 when Trunc_Div_Expr
=>
554 when Ceil_Div_Expr
=>
557 when Floor_Div_Expr
=>
560 when Trunc_Mod_Expr
=>
563 when Floor_Mod_Expr
=>
566 when Ceil_Mod_Expr
=>
569 when Exact_Div_Expr
=>
574 Print_Expr
(Node
.Op1
);
584 Print_Expr
(Node
.Op1
);
586 when Truth_Andif_Expr
=>
589 when Truth_Orif_Expr
=>
592 when Truth_And_Expr
=>
595 when Truth_Or_Expr
=>
598 when Truth_Xor_Expr
=>
601 when Truth_Not_Expr
=>
603 Print_Expr
(Node
.Op1
);
635 -- Start of processing for List_GCC_Expression
643 end List_GCC_Expression
;
645 -------------------------
646 -- List_Linker_Section --
647 -------------------------
649 procedure List_Linker_Section
(Ent
: Entity_Id
) is
653 if Present
(Linker_Section_Pragma
(Ent
)) then
654 Write_Str
("pragma Linker_Section (");
659 Last
(Pragma_Argument_Associations
(Linker_Section_Pragma
(Ent
)));
661 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
662 Arg
:= Expression
(Arg
);
665 pragma Assert
(Nkind
(Arg
) = N_String_Literal
);
666 String_To_Name_Buffer
(Strval
(Arg
));
667 Write_Str
(Name_Buffer
(1 .. Name_Len
));
671 end List_Linker_Section
;
673 ---------------------
674 -- List_Mechanisms --
675 ---------------------
677 procedure List_Mechanisms
(Ent
: Entity_Id
) is
686 Write_Str
("function ");
689 Write_Str
("operator ");
692 Write_Str
("procedure ");
694 when E_Subprogram_Type
=>
697 when E_Entry | E_Entry_Family
=>
698 Write_Str
("entry ");
704 Get_Unqualified_Decoded_Name_String
(Chars
(Ent
));
705 Write_Str
(Name_Buffer
(1 .. Name_Len
));
706 Write_Str
(" declared at ");
707 Write_Location
(Sloc
(Ent
));
710 Write_Str
(" convention : ");
712 case Convention
(Ent
) is
713 when Convention_Ada
=>
715 when Convention_Ada_Pass_By_Copy
=>
716 Write_Line
("Ada_Pass_By_Copy");
717 when Convention_Ada_Pass_By_Reference
=>
718 Write_Line
("Ada_Pass_By_Reference");
719 when Convention_Intrinsic
=>
720 Write_Line
("Intrinsic");
721 when Convention_Entry
=>
722 Write_Line
("Entry");
723 when Convention_Protected
=>
724 Write_Line
("Protected");
725 when Convention_Assembler
=>
726 Write_Line
("Assembler");
729 when Convention_CIL
=>
731 when Convention_COBOL
=>
732 Write_Line
("COBOL");
733 when Convention_CPP
=>
735 when Convention_Fortran
=>
736 Write_Line
("Fortran");
737 when Convention_Java
=>
739 when Convention_Stdcall
=>
740 Write_Line
("Stdcall");
741 when Convention_Stubbed
=>
742 Write_Line
("Stubbed");
745 -- Find max length of formal name
748 Form
:= First_Formal
(Ent
);
749 while Present
(Form
) loop
750 Get_Unqualified_Decoded_Name_String
(Chars
(Form
));
752 if Name_Len
> Plen
then
759 -- Output formals and mechanisms
761 Form
:= First_Formal
(Ent
);
762 while Present
(Form
) loop
763 Get_Unqualified_Decoded_Name_String
(Chars
(Form
));
764 while Name_Len
<= Plen
loop
765 Name_Len
:= Name_Len
+ 1;
766 Name_Buffer
(Name_Len
) := ' ';
770 Write_Str
(Name_Buffer
(1 .. Plen
+ 1));
771 Write_Str
(": passed by ");
773 Write_Mechanism
(Mechanism
(Form
));
778 if Etype
(Ent
) /= Standard_Void_Type
then
779 Write_Str
(" returns by ");
780 Write_Mechanism
(Mechanism
(Ent
));
789 procedure List_Name
(Ent
: Entity_Id
) is
791 if not Is_Compilation_Unit
(Scope
(Ent
)) then
792 List_Name
(Scope
(Ent
));
796 Get_Unqualified_Decoded_Name_String
(Chars
(Ent
));
797 Set_Casing
(Unit_Casing
);
798 Write_Str
(Name_Buffer
(1 .. Name_Len
));
801 ---------------------
802 -- List_Object_Info --
803 ---------------------
805 procedure List_Object_Info
(Ent
: Entity_Id
) is
811 Write_Str
("'Size use ");
812 Write_Val
(Esize
(Ent
));
817 Write_Str
("'Alignment use ");
818 Write_Val
(Alignment
(Ent
));
820 end List_Object_Info
;
822 ----------------------
823 -- List_Record_Info --
824 ----------------------
826 procedure List_Record_Info
(Ent
: Entity_Id
; Bytes_Big_Endian
: Boolean) is
831 Max_Name_Length
: Natural;
832 Max_Suni_Length
: Natural;
836 List_Type_Info
(Ent
);
840 Write_Line
(" use record");
842 -- First loop finds out max line length and max starting position
843 -- length, for the purpose of lining things up nicely.
845 Max_Name_Length
:= 0;
846 Max_Suni_Length
:= 0;
848 Comp
:= First_Component_Or_Discriminant
(Ent
);
849 while Present
(Comp
) loop
851 -- Skip discriminant in unchecked union (since it is not there!)
853 if Ekind
(Comp
) = E_Discriminant
854 and then Is_Unchecked_Union
(Ent
)
861 Get_Decoded_Name_String
(Chars
(Comp
));
862 Max_Name_Length
:= Natural'Max (Max_Name_Length
, Name_Len
);
864 Cfbit
:= Component_Bit_Offset
(Comp
);
866 if Rep_Not_Constant
(Cfbit
) then
867 UI_Image_Length
:= 2;
870 -- Complete annotation in case not done
872 Set_Normalized_Position
(Comp
, Cfbit
/ SSU
);
873 Set_Normalized_First_Bit
(Comp
, Cfbit
mod SSU
);
875 Sunit
:= Cfbit
/ SSU
;
879 -- If the record is not packed, then we know that all fields
880 -- whose position is not specified have a starting normalized
881 -- bit position of zero.
883 if Unknown_Normalized_First_Bit
(Comp
)
884 and then not Is_Packed
(Ent
)
886 Set_Normalized_First_Bit
(Comp
, Uint_0
);
890 Natural'Max (Max_Suni_Length
, UI_Image_Length
);
893 Next_Component_Or_Discriminant
(Comp
);
896 -- Second loop does actual output based on those values
898 Comp
:= First_Component_Or_Discriminant
(Ent
);
899 while Present
(Comp
) loop
901 -- Skip discriminant in unchecked union (since it is not there!)
903 if Ekind
(Comp
) = E_Discriminant
904 and then Is_Unchecked_Union
(Ent
)
912 Esiz
: constant Uint
:= Esize
(Comp
);
913 Bofs
: constant Uint
:= Component_Bit_Offset
(Comp
);
914 Npos
: constant Uint
:= Normalized_Position
(Comp
);
915 Fbit
: constant Uint
:= Normalized_First_Bit
(Comp
);
920 Get_Decoded_Name_String
(Chars
(Comp
));
921 Set_Casing
(Unit_Casing
);
922 Write_Str
(Name_Buffer
(1 .. Name_Len
));
924 for J
in 1 .. Max_Name_Length
- Name_Len
loop
930 if Known_Static_Normalized_Position
(Comp
) then
932 Spaces
(Max_Suni_Length
- UI_Image_Length
);
933 Write_Str
(UI_Image_Buffer
(1 .. UI_Image_Length
));
935 elsif Known_Component_Bit_Offset
(Comp
)
936 and then List_Representation_Info
= 3
938 Spaces
(Max_Suni_Length
- 2);
939 Write_Str
("bit offset");
940 Write_Val
(Bofs
, Paren
=> True);
941 Write_Str
(" size in bits = ");
942 Write_Val
(Esiz
, Paren
=> True);
946 elsif Known_Normalized_Position
(Comp
)
947 and then List_Representation_Info
= 3
949 Spaces
(Max_Suni_Length
- 2);
953 -- For the packed case, we don't know the bit positions if we
954 -- don't know the starting position.
956 if Is_Packed
(Ent
) then
957 Write_Line
("?? range ? .. ??;");
960 -- Otherwise we can continue
967 Write_Str
(" range ");
971 -- Allowing Uint_0 here is an annoying special case. Really this
972 -- should be a fine Esize value but currently it means unknown,
973 -- except that we know after gigi has back annotated that a size
974 -- of zero is real, since otherwise gigi back annotates using
975 -- No_Uint as the value to indicate unknown).
977 if (Esize
(Comp
) = Uint_0
or else Known_Static_Esize
(Comp
))
978 and then Known_Static_Normalized_First_Bit
(Comp
)
980 Lbit
:= Fbit
+ Esiz
- 1;
988 -- The test for Esize (Comp) not Uint_0 here is an annoying
989 -- special case. Officially a value of zero for Esize means
990 -- unknown, but here we use the fact that we know that gigi
991 -- annotates Esize with No_Uint, not Uint_0. Really everyone
992 -- should use No_Uint???
994 elsif List_Representation_Info
< 3
995 or else (Esize
(Comp
) /= Uint_0
and then Unknown_Esize
(Comp
))
999 -- List_Representation >= 3 and Known_Esize (Comp)
1002 Write_Val
(Esiz
, Paren
=> True);
1004 -- If in front end layout mode, then dynamic size is stored
1005 -- in storage units, so renormalize for output
1007 if not Back_End_Layout
then
1012 -- Add appropriate first bit offset
1022 Write_Int
(UI_To_Int
(Fbit
) - 1);
1030 Next_Component_Or_Discriminant
(Comp
);
1033 Write_Line
("end record;");
1035 List_Scalar_Storage_Order
(Ent
, Bytes_Big_Endian
);
1036 end List_Record_Info
;
1042 procedure List_Rep_Info
(Bytes_Big_Endian
: Boolean) is
1046 if List_Representation_Info
/= 0
1047 or else List_Representation_Info_Mechanisms
1049 for U
in Main_Unit
.. Last_Unit
loop
1050 if In_Extended_Main_Source_Unit
(Cunit_Entity
(U
)) then
1051 Unit_Casing
:= Identifier_Casing
(Source_Index
(U
));
1053 -- Normal case, list to standard output
1055 if not List_Representation_Info_To_File
then
1057 Write_Str
("Representation information for unit ");
1058 Write_Unit_Name
(Unit_Name
(U
));
1062 for J
in 1 .. Col
- 1 loop
1067 List_Entities
(Cunit_Entity
(U
), Bytes_Big_Endian
);
1069 -- List representation information to file
1072 Create_Repinfo_File_Access
.all
1073 (Get_Name_String
(File_Name
(Source_Index
(U
))));
1074 Set_Special_Output
(Write_Info_Line
'Access);
1075 List_Entities
(Cunit_Entity
(U
), Bytes_Big_Endian
);
1076 Set_Special_Output
(null);
1077 Close_Repinfo_File_Access
.all;
1084 -------------------------------
1085 -- List_Scalar_Storage_Order --
1086 -------------------------------
1088 procedure List_Scalar_Storage_Order
1090 Bytes_Big_Endian
: Boolean)
1092 procedure List_Attr
(Attr_Name
: String; Is_Reversed
: Boolean);
1093 -- Show attribute definition clause for Attr_Name (an endianness
1094 -- attribute), depending on whether or not the endianness is reversed
1095 -- compared to native endianness.
1101 procedure List_Attr
(Attr_Name
: String; Is_Reversed
: Boolean) is
1105 Write_Str
("'" & Attr_Name
& " use System.");
1107 if Bytes_Big_Endian
xor Is_Reversed
then
1113 Write_Line
("_Order_First;");
1116 List_SSO
: constant Boolean :=
1117 Has_Rep_Item
(Ent
, Name_Scalar_Storage_Order
)
1118 or else SSO_Set_Low_By_Default
(Ent
)
1119 or else SSO_Set_High_By_Default
(Ent
);
1120 -- Scalar_Storage_Order is displayed if specified explicitly
1121 -- or set by Default_Scalar_Storage_Order.
1123 -- Start of processing for List_Scalar_Storage_Order
1126 -- For record types, list Bit_Order if not default, or if SSO is shown
1128 if Is_Record_Type
(Ent
)
1129 and then (List_SSO
or else Reverse_Bit_Order
(Ent
))
1131 List_Attr
("Bit_Order", Reverse_Bit_Order
(Ent
));
1134 -- List SSO if required. If not, then storage is supposed to be in
1138 List_Attr
("Scalar_Storage_Order", Reverse_Storage_Order
(Ent
));
1140 pragma Assert
(not Reverse_Storage_Order
(Ent
));
1143 end List_Scalar_Storage_Order
;
1145 --------------------
1146 -- List_Type_Info --
1147 --------------------
1149 procedure List_Type_Info
(Ent
: Entity_Id
) is
1153 -- Do not list size info for unconstrained arrays, not meaningful
1155 if Is_Array_Type
(Ent
) and then not Is_Constrained
(Ent
) then
1159 -- If Esize and RM_Size are the same and known, list as Size. This
1160 -- is a common case, which we may as well list in simple form.
1162 if Esize
(Ent
) = RM_Size
(Ent
) then
1165 Write_Str
("'Size use ");
1166 Write_Val
(Esize
(Ent
));
1169 -- For now, temporary case, to be removed when gigi properly back
1170 -- annotates RM_Size, if RM_Size is not set, then list Esize as Size.
1171 -- This avoids odd Object_Size output till we fix things???
1173 elsif Unknown_RM_Size
(Ent
) then
1176 Write_Str
("'Size use ");
1177 Write_Val
(Esize
(Ent
));
1180 -- Otherwise list size values separately if they are set
1185 Write_Str
("'Object_Size use ");
1186 Write_Val
(Esize
(Ent
));
1189 -- Note on following check: The RM_Size of a discrete type can
1190 -- legitimately be set to zero, so a special check is needed.
1194 Write_Str
("'Value_Size use ");
1195 Write_Val
(RM_Size
(Ent
));
1202 Write_Str
("'Alignment use ");
1203 Write_Val
(Alignment
(Ent
));
1206 -- Special stuff for fixed-point
1208 if Is_Fixed_Point_Type
(Ent
) then
1210 -- Write small (always a static constant)
1214 Write_Str
("'Small use ");
1215 UR_Write
(Small_Value
(Ent
));
1218 -- Write range if static
1221 R
: constant Node_Id
:= Scalar_Range
(Ent
);
1224 if Nkind
(Low_Bound
(R
)) = N_Real_Literal
1226 Nkind
(High_Bound
(R
)) = N_Real_Literal
1230 Write_Str
("'Range use ");
1231 UR_Write
(Realval
(Low_Bound
(R
)));
1233 UR_Write
(Realval
(High_Bound
(R
)));
1240 ----------------------
1241 -- Rep_Not_Constant --
1242 ----------------------
1244 function Rep_Not_Constant
(Val
: Node_Ref_Or_Val
) return Boolean is
1246 if Val
= No_Uint
or else Val
< 0 then
1251 end Rep_Not_Constant
;
1258 (Val
: Node_Ref_Or_Val
;
1259 D
: Discrim_List
) return Uint
1261 function B
(Val
: Boolean) return Uint
;
1262 -- Returns Uint_0 for False, Uint_1 for True
1264 function T
(Val
: Node_Ref_Or_Val
) return Boolean;
1265 -- Returns True for 0, False for any non-zero (i.e. True)
1267 function V
(Val
: Node_Ref_Or_Val
) return Uint
;
1268 -- Internal recursive routine to evaluate tree
1270 function W
(Val
: Uint
) return Word
;
1271 -- Convert Val to Word, assuming Val is always in the Int range. This
1272 -- is a helper function for the evaluation of bitwise expressions like
1273 -- Bit_And_Expr, for which there is no direct support in uintp. Uint
1274 -- values out of the Int range are expected to be seen in such
1275 -- expressions only with overflowing byte sizes around, introducing
1276 -- inherent unreliabilities in computations anyway.
1282 function B
(Val
: Boolean) return Uint
is
1295 function T
(Val
: Node_Ref_Or_Val
) return Boolean is
1308 function V
(Val
: Node_Ref_Or_Val
) return Uint
is
1317 Node
: Exp_Node
renames Rep_Table
.Table
(-UI_To_Int
(Val
));
1322 if T
(Node
.Op1
) then
1323 return V
(Node
.Op2
);
1325 return V
(Node
.Op3
);
1329 return V
(Node
.Op1
) + V
(Node
.Op2
);
1332 return V
(Node
.Op1
) - V
(Node
.Op2
);
1335 return V
(Node
.Op1
) * V
(Node
.Op2
);
1337 when Trunc_Div_Expr
=>
1338 return V
(Node
.Op1
) / V
(Node
.Op2
);
1340 when Ceil_Div_Expr
=>
1343 (V
(Node
.Op1
) / UR_From_Uint
(V
(Node
.Op2
)));
1345 when Floor_Div_Expr
=>
1348 (V
(Node
.Op1
) / UR_From_Uint
(V
(Node
.Op2
)));
1350 when Trunc_Mod_Expr
=>
1351 return V
(Node
.Op1
) rem V
(Node
.Op2
);
1353 when Floor_Mod_Expr
=>
1354 return V
(Node
.Op1
) mod V
(Node
.Op2
);
1356 when Ceil_Mod_Expr
=>
1359 Q
:= UR_Ceiling
(L
/ UR_From_Uint
(R
));
1362 when Exact_Div_Expr
=>
1363 return V
(Node
.Op1
) / V
(Node
.Op2
);
1366 return -V
(Node
.Op1
);
1369 return UI_Min
(V
(Node
.Op1
), V
(Node
.Op2
));
1372 return UI_Max
(V
(Node
.Op1
), V
(Node
.Op2
));
1375 return UI_Abs
(V
(Node
.Op1
));
1377 when Truth_Andif_Expr
=>
1378 return B
(T
(Node
.Op1
) and then T
(Node
.Op2
));
1380 when Truth_Orif_Expr
=>
1381 return B
(T
(Node
.Op1
) or else T
(Node
.Op2
));
1383 when Truth_And_Expr
=>
1384 return B
(T
(Node
.Op1
) and then T
(Node
.Op2
));
1386 when Truth_Or_Expr
=>
1387 return B
(T
(Node
.Op1
) or else T
(Node
.Op2
));
1389 when Truth_Xor_Expr
=>
1390 return B
(T
(Node
.Op1
) xor T
(Node
.Op2
));
1392 when Truth_Not_Expr
=>
1393 return B
(not T
(Node
.Op1
));
1395 when Bit_And_Expr
=>
1398 return UI_From_Int
(Int
(W
(L
) and W
(R
)));
1401 return B
(V
(Node
.Op1
) < V
(Node
.Op2
));
1404 return B
(V
(Node
.Op1
) <= V
(Node
.Op2
));
1407 return B
(V
(Node
.Op1
) > V
(Node
.Op2
));
1410 return B
(V
(Node
.Op1
) >= V
(Node
.Op2
));
1413 return B
(V
(Node
.Op1
) = V
(Node
.Op2
));
1416 return B
(V
(Node
.Op1
) /= V
(Node
.Op2
));
1420 Sub
: constant Int
:= UI_To_Int
(Node
.Op1
);
1422 pragma Assert
(Sub
in D
'Range);
1435 -- We use an unchecked conversion to map Int values to their Word
1436 -- bitwise equivalent, which we could not achieve with a normal type
1437 -- conversion for negative Ints. We want bitwise equivalents because W
1438 -- is used as a helper for bit operators like Bit_And_Expr, and can be
1439 -- called for negative Ints in the context of aligning expressions like
1440 -- X+Align & -Align.
1442 function W
(Val
: Uint
) return Word
is
1443 function To_Word
is new Ada
.Unchecked_Conversion
(Int
, Word
);
1445 return To_Word
(UI_To_Int
(Val
));
1448 -- Start of processing for Rep_Value
1451 if Val
= No_Uint
then
1463 procedure Spaces
(N
: Natural) is
1465 for J
in 1 .. N
loop
1474 procedure Tree_Read
is
1476 Rep_Table
.Tree_Read
;
1483 procedure Tree_Write
is
1485 Rep_Table
.Tree_Write
;
1488 ---------------------
1489 -- Write_Info_Line --
1490 ---------------------
1492 procedure Write_Info_Line
(S
: String) is
1494 Write_Repinfo_Line_Access
.all (S
(S
'First .. S
'Last - 1));
1495 end Write_Info_Line
;
1497 ---------------------
1498 -- Write_Mechanism --
1499 ---------------------
1501 procedure Write_Mechanism
(M
: Mechanism_Type
) is
1505 Write_Str
("default");
1511 Write_Str
("reference");
1514 raise Program_Error
;
1516 end Write_Mechanism
;
1522 procedure Write_Val
(Val
: Node_Ref_Or_Val
; Paren
: Boolean := False) is
1524 if Rep_Not_Constant
(Val
) then
1525 if List_Representation_Info
< 3 or else Val
= No_Uint
then
1529 if Back_End_Layout
then
1534 List_GCC_Expression
(Val
);
1537 List_GCC_Expression
(Val
);
1545 Write_Name_Decoded
(Chars
(Get_Dynamic_SO_Entity
(Val
)));
1548 Write_Name_Decoded
(Chars
(Get_Dynamic_SO_Entity
(Val
)));