1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- B I N D O . W R I T E R S --
9 -- Copyright (C) 2019-2023, 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. 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Binderr
; use Binderr
;
27 with Butil
; use Butil
;
28 with Debug
; use Debug
;
29 with Fname
; use Fname
;
31 with Output
; use Output
;
37 with GNAT
.Graphs
; use GNAT
.Graphs
;
38 with GNAT
.Sets
; use GNAT
.Sets
;
40 package body Bindo
.Writers
is
46 package body ALI_Writers
is
48 -----------------------
49 -- Local subprograms --
50 -----------------------
52 procedure Write_All_Units
;
53 pragma Inline
(Write_All_Units
);
54 -- Write the common form of units to standard output
56 procedure Write_Invocation_Construct
(IC_Id
: Invocation_Construct_Id
);
57 pragma Inline
(Write_Invocation_Construct
);
58 -- Write invocation construct IC_Id to standard output
60 procedure Write_Invocation_Relation
(IR_Id
: Invocation_Relation_Id
);
61 pragma Inline
(Write_Invocation_Relation
);
62 -- Write invocation relation IR_Id to standard output
64 procedure Write_Invocation_Signature
(IS_Id
: Invocation_Signature_Id
);
65 pragma Inline
(Write_Invocation_Signature
);
66 -- Write invocation signature IS_Id to standard output
68 procedure Write_Statistics
;
69 pragma Inline
(Write_Statistics
);
70 -- Write the statistical information of units to standard output
72 procedure Write_Unit
(U_Id
: Unit_Id
);
73 pragma Inline
(Write_Unit
);
74 -- Write the invocation constructs and relations of unit U_Id to
77 procedure Write_Unit_Common
(U_Id
: Unit_Id
);
78 pragma Inline
(Write_Unit_Common
);
79 -- Write the common form of unit U_Id to standard output
85 procedure pau
renames Write_All_Units
;
86 pragma Unreferenced
(pau
);
88 procedure pu
(U_Id
: Unit_Id
) renames Write_Unit_Common
;
89 pragma Unreferenced
(pu
);
91 ----------------------
92 -- Write_ALI_Tables --
93 ----------------------
95 procedure Write_ALI_Tables
is
97 -- Nothing to do when switch -d_A (output invocation tables) is not
100 if not Debug_Flag_Underscore_AA
then
104 Write_Str
("ALI Tables");
109 For_Each_Unit
(Write_Unit
'Access);
111 Write_Str
("ALI Tables end");
114 end Write_ALI_Tables
;
116 ---------------------
117 -- Write_All_Units --
118 ---------------------
120 procedure Write_All_Units
is
122 For_Each_Unit
(Write_Unit_Common
'Access);
125 --------------------------------
126 -- Write_Invocation_Construct --
127 --------------------------------
129 procedure Write_Invocation_Construct
(IC_Id
: Invocation_Construct_Id
) is
131 pragma Assert
(Present
(IC_Id
));
133 Write_Str
(" invocation construct (IC_Id_");
134 Write_Int
(Int
(IC_Id
));
138 Write_Str
(" Body_Placement = ");
139 Write_Str
(Body_Placement
(IC_Id
)'Img);
142 Write_Str
(" Kind = ");
143 Write_Str
(Kind
(IC_Id
)'Img);
146 Write_Str
(" Spec_Placement = ");
147 Write_Str
(Spec_Placement
(IC_Id
)'Img);
150 Write_Invocation_Signature
(Signature
(IC_Id
));
152 end Write_Invocation_Construct
;
154 -------------------------------
155 -- Write_Invocation_Relation --
156 -------------------------------
158 procedure Write_Invocation_Relation
(IR_Id
: Invocation_Relation_Id
) is
160 pragma Assert
(Present
(IR_Id
));
162 Write_Str
(" invocation relation (IR_Id_");
163 Write_Int
(Int
(IR_Id
));
167 if Present
(Extra
(IR_Id
)) then
168 Write_Str
(" Extra = ");
169 Write_Name
(Extra
(IR_Id
));
171 Write_Str
(" Extra = none");
175 Write_Str
(" Invoker");
178 Write_Invocation_Signature
(Invoker
(IR_Id
));
180 Write_Str
(" Kind = ");
181 Write_Str
(Kind
(IR_Id
)'Img);
184 Write_Str
(" Target");
187 Write_Invocation_Signature
(Target
(IR_Id
));
189 end Write_Invocation_Relation
;
191 --------------------------------
192 -- Write_Invocation_Signature --
193 --------------------------------
195 procedure Write_Invocation_Signature
(IS_Id
: Invocation_Signature_Id
) is
197 pragma Assert
(Present
(IS_Id
));
199 Write_Str
(" Signature (IS_Id_");
200 Write_Int
(Int
(IS_Id
));
204 Write_Str
(" Column = ");
205 Write_Int
(Int
(Column
(IS_Id
)));
208 Write_Str
(" Line = ");
209 Write_Int
(Int
(Line
(IS_Id
)));
212 if Present
(Locations
(IS_Id
)) then
213 Write_Str
(" Locations = ");
214 Write_Name
(Locations
(IS_Id
));
216 Write_Str
(" Locations = none");
220 Write_Str
(" Name = ");
221 Write_Name
(Name
(IS_Id
));
224 Write_Str
(" Scope = ");
225 Write_Name
(IS_Scope
(IS_Id
));
227 end Write_Invocation_Signature
;
229 ----------------------
230 -- Write_Statistics --
231 ----------------------
233 procedure Write_Statistics
is
235 Write_Str
("Units : ");
236 Write_Num
(Int
(Number_Of_Units
));
239 Write_Str
("Units to elaborate: ");
240 Write_Num
(Int
(Number_Of_Elaborable_Units
));
243 end Write_Statistics
;
249 procedure Write_Unit
(U_Id
: Unit_Id
) is
250 pragma Assert
(Present
(U_Id
));
252 U_Rec
: Unit_Record
renames ALI
.Units
.Table
(U_Id
);
255 Write_Unit_Common
(U_Id
);
257 Write_Str
(" First_Invocation_Construct (IC_Id_");
258 Write_Int
(Int
(U_Rec
.First_Invocation_Construct
));
262 Write_Str
(" Last_Invocation_Construct (IC_Id_");
263 Write_Int
(Int
(U_Rec
.Last_Invocation_Construct
));
267 Write_Str
(" First_Invocation_Relation (IR_Id_");
268 Write_Int
(Int
(U_Rec
.First_Invocation_Relation
));
272 Write_Str
(" Last_Invocation_Relation (IR_Id_");
273 Write_Int
(Int
(U_Rec
.Last_Invocation_Relation
));
277 Write_Str
(" Invocation_Graph_Encoding = ");
278 Write_Str
(Invocation_Graph_Encoding
(U_Id
)'Img);
282 For_Each_Invocation_Construct
284 Processor
=> Write_Invocation_Construct
'Access);
286 For_Each_Invocation_Relation
288 Processor
=> Write_Invocation_Relation
'Access);
291 -----------------------
292 -- Write_Unit_Common --
293 -----------------------
295 procedure Write_Unit_Common
(U_Id
: Unit_Id
) is
296 pragma Assert
(Present
(U_Id
));
298 U_Rec
: Unit_Record
renames ALI
.Units
.Table
(U_Id
);
301 Write_Str
("unit (U_Id_");
302 Write_Int
(Int
(U_Id
));
303 Write_Str
(") name = ");
304 Write_Name
(U_Rec
.Uname
);
307 if U_Rec
.SAL_Interface
then
308 Write_Str
(" SAL_Interface = True");
311 end Write_Unit_Common
;
318 package body Cycle_Writers
is
320 -----------------------
321 -- Local subprograms --
322 -----------------------
324 procedure Write_Cycle
326 Cycle
: Library_Graph_Cycle_Id
);
327 pragma Inline
(Write_Cycle
);
328 -- Write the path of cycle Cycle found in library graph G to standard
331 procedure Write_Cyclic_Edge
333 Edge
: Library_Graph_Edge_Id
);
334 pragma Inline
(Write_Cyclic_Edge
);
335 -- Write cyclic edge Edge of library graph G to standard
341 procedure palgc
(G
: Library_Graph
) renames Write_Cycles
;
342 pragma Unreferenced
(palgc
);
346 Cycle
: Library_Graph_Cycle_Id
) renames Write_Cycle
;
347 pragma Unreferenced
(plgc
);
353 procedure Write_Cycle
355 Cycle
: Library_Graph_Cycle_Id
)
357 Edge
: Library_Graph_Edge_Id
;
358 Iter
: Edges_Of_Cycle_Iterator
;
361 pragma Assert
(Present
(G
));
362 pragma Assert
(Present
(Cycle
));
364 -- Nothing to do when switch -d_P (output cycle paths) is not in
367 if not Debug_Flag_Underscore_PP
then
371 Write_Str
("cycle (LGC_Id_");
372 Write_Int
(Int
(Cycle
));
376 Iter
:= Iterate_Edges_Of_Cycle
(G
, Cycle
);
377 while Has_Next
(Iter
) loop
380 Write_Cyclic_Edge
(G
, Edge
);
390 procedure Write_Cycles
(G
: Library_Graph
) is
391 Cycle
: Library_Graph_Cycle_Id
;
392 Iter
: All_Cycle_Iterator
;
395 pragma Assert
(Present
(G
));
397 Iter
:= Iterate_All_Cycles
(G
);
398 while Has_Next
(Iter
) loop
401 Write_Cycle
(G
, Cycle
);
405 -----------------------
406 -- Write_Cyclic_Edge --
407 -----------------------
409 procedure Write_Cyclic_Edge
411 Edge
: Library_Graph_Edge_Id
)
413 pragma Assert
(Present
(G
));
414 pragma Assert
(Present
(Edge
));
416 Pred
: constant Library_Graph_Vertex_Id
:= Predecessor
(G
, Edge
);
417 Succ
: constant Library_Graph_Vertex_Id
:= Successor
(G
, Edge
);
420 Indent_By
(Nested_Indentation
);
421 Write_Name
(Name
(G
, Succ
));
423 Write_Name
(Name
(G
, Pred
));
426 if Is_Elaborate_All_Edge
(G
, Edge
) then
427 Write_Str
("Elaborate_All edge");
429 elsif Is_Elaborate_Body_Edge
(G
, Edge
) then
430 Write_Str
("Elaborate_Body edge");
432 elsif Is_Elaborate_Edge
(G
, Edge
) then
433 Write_Str
("Elaborate edge");
435 elsif Is_Forced_Edge
(G
, Edge
) then
436 Write_Str
("forced edge");
438 elsif Is_Invocation_Edge
(G
, Edge
) then
439 Write_Str
("invocation edge");
442 pragma Assert
(Is_With_Edge
(G
, Edge
));
444 Write_Str
("with edge");
448 end Write_Cyclic_Edge
;
451 ------------------------
452 -- Dependency_Writers --
453 ------------------------
455 package body Dependency_Writers
is
457 -----------------------
458 -- Local subprograms --
459 -----------------------
461 procedure Write_Dependencies_Of_Vertex
463 Vertex
: Library_Graph_Vertex_Id
);
464 pragma Inline
(Write_Dependencies_Of_Vertex
);
465 -- Write the dependencies of vertex Vertex of library graph G to
468 procedure Write_Dependency_Edge
470 Edge
: Library_Graph_Edge_Id
);
471 pragma Inline
(Write_Dependency_Edge
);
472 -- Write the dependency described by edge Edge of library graph G to
475 ------------------------
476 -- Write_Dependencies --
477 ------------------------
479 procedure Write_Dependencies
(G
: Library_Graph
) is
480 Use_Formatting
: constant Boolean := not Zero_Formatting
;
482 Iter
: Library_Graphs
.All_Vertex_Iterator
;
483 Vertex
: Library_Graph_Vertex_Id
;
486 pragma Assert
(Present
(G
));
488 -- Nothing to do when switch -e (output complete list of elaboration
489 -- order dependencies) is not in effect.
491 if not Elab_Dependency_Output
then
495 if Use_Formatting
then
497 Write_Line
("ELABORATION ORDER DEPENDENCIES");
501 Info_Prefix_Suppress
:= True;
503 Iter
:= Iterate_All_Vertices
(G
);
504 while Has_Next
(Iter
) loop
507 Write_Dependencies_Of_Vertex
(G
, Vertex
);
510 Info_Prefix_Suppress
:= False;
512 if Use_Formatting
then
515 end Write_Dependencies
;
517 ----------------------------------
518 -- Write_Dependencies_Of_Vertex --
519 ----------------------------------
521 procedure Write_Dependencies_Of_Vertex
523 Vertex
: Library_Graph_Vertex_Id
)
525 Edge
: Library_Graph_Edge_Id
;
526 Iter
: Edges_To_Successors_Iterator
;
529 pragma Assert
(Present
(G
));
530 pragma Assert
(Present
(Vertex
));
532 -- Nothing to do for internal and predefined units
534 if Is_Internal_Unit
(G
, Vertex
)
535 or else Is_Predefined_Unit
(G
, Vertex
)
540 Iter
:= Iterate_Edges_To_Successors
(G
, Vertex
);
541 while Has_Next
(Iter
) loop
544 Write_Dependency_Edge
(G
, Edge
);
546 end Write_Dependencies_Of_Vertex
;
548 ---------------------------
549 -- Write_Dependency_Edge --
550 ---------------------------
552 procedure Write_Dependency_Edge
554 Edge
: Library_Graph_Edge_Id
)
556 pragma Assert
(Present
(G
));
557 pragma Assert
(Present
(Edge
));
559 Pred
: constant Library_Graph_Vertex_Id
:= Predecessor
(G
, Edge
);
560 Succ
: constant Library_Graph_Vertex_Id
:= Successor
(G
, Edge
);
563 -- Nothing to do for internal and predefined units
565 if Is_Internal_Unit
(G
, Succ
)
566 or else Is_Predefined_Unit
(G
, Succ
)
571 Error_Msg_Unit_1
:= Name
(G
, Pred
);
572 Error_Msg_Unit_2
:= Name
(G
, Succ
);
574 (Msg
=> " unit $ must be elaborated before unit $",
577 Error_Msg_Unit_1
:= Name
(G
, Succ
);
578 Error_Msg_Unit_2
:= Name
(G
, Pred
);
580 if Is_Elaborate_All_Edge
(G
, Edge
) then
583 " reason: unit $ has with clause and pragma "
584 & "Elaborate_All for unit $",
587 elsif Is_Elaborate_Body_Edge
(G
, Edge
) then
589 (Msg
=> " reason: unit $ has with clause for unit $",
592 elsif Is_Elaborate_Edge
(G
, Edge
) then
595 " reason: unit $ has with clause and pragma Elaborate "
599 elsif Is_Forced_Edge
(G
, Edge
) then
602 " reason: unit $ has a dependency on unit $ forced by -f "
606 elsif Is_Invocation_Edge
(G
, Edge
) then
609 " reason: unit $ invokes a construct of unit $ at "
610 & "elaboration time",
613 elsif Is_Spec_Before_Body_Edge
(G
, Edge
) then
615 (Msg
=> " reason: spec must be elaborated before body",
619 pragma Assert
(Is_With_Edge
(G
, Edge
));
622 (Msg
=> " reason: unit $ has with clause for unit $",
625 end Write_Dependency_Edge
;
626 end Dependency_Writers
;
628 -------------------------------
629 -- Elaboration_Order_Writers --
630 -------------------------------
632 package body Elaboration_Order_Writers
is
634 -----------------------
635 -- Local subprograms --
636 -----------------------
638 procedure Write_Unit
(U_Id
: Unit_Id
);
639 pragma Inline
(Write_Unit
);
640 -- Write unit U_Id to standard output
642 procedure Write_Units
(Order
: Unit_Id_Table
);
643 pragma Inline
(Write_Units
);
644 -- Write all units found in elaboration order Order to standard output
646 -----------------------------
647 -- Write_Elaboration_Order --
648 -----------------------------
650 procedure Write_Elaboration_Order
(Order
: Unit_Id_Table
) is
651 Use_Formatting
: constant Boolean := not Zero_Formatting
;
654 -- Nothing to do when switch -l (output chosen elaboration order) is
657 if not Elab_Order_Output
then
661 if Use_Formatting
then
663 Write_Str
("ELABORATION ORDER");
669 if Use_Formatting
then
672 end Write_Elaboration_Order
;
678 procedure Write_Unit
(U_Id
: Unit_Id
) is
679 Use_Formatting
: constant Boolean := not Zero_Formatting
;
682 pragma Assert
(Present
(U_Id
));
684 if Use_Formatting
then
688 Write_Unit_Name
(Name
(U_Id
));
696 procedure Write_Units
(Order
: Unit_Id_Table
) is
698 for Index
in Unit_Id_Tables
.First
.. Unit_Id_Tables
.Last
(Order
) loop
699 Write_Unit
(Order
.Table
(Index
));
702 end Elaboration_Order_Writers
;
708 procedure Indent_By
(Indent
: Indentation_Level
) is
710 for Count
in 1 .. Indent
loop
715 ------------------------------
716 -- Invocation_Graph_Writers --
717 ------------------------------
719 package body Invocation_Graph_Writers
is
721 -----------------------
722 -- Local subprograms --
723 -----------------------
725 procedure Write_Elaboration_Root
726 (G
: Invocation_Graph
;
727 Root
: Invocation_Graph_Vertex_Id
);
728 pragma Inline
(Write_Elaboration_Root
);
729 -- Write elaboration root Root of invocation graph G to standard output
731 procedure Write_Elaboration_Roots
(G
: Invocation_Graph
);
732 pragma Inline
(Write_Elaboration_Roots
);
733 -- Write all elaboration roots of invocation graph G to standard output
735 procedure Write_Invocation_Graph_Edge
736 (G
: Invocation_Graph
;
737 Edge
: Invocation_Graph_Edge_Id
);
738 pragma Inline
(Write_Invocation_Graph_Edge
);
739 -- Write edge Edge of invocation graph G to standard output
741 procedure Write_Invocation_Graph_Edges
742 (G
: Invocation_Graph
;
743 Vertex
: Invocation_Graph_Vertex_Id
);
744 pragma Inline
(Write_Invocation_Graph_Edges
);
745 -- Write all edges to targets of vertex Vertex of invocation graph G to
748 procedure Write_Invocation_Graph_Vertex
749 (G
: Invocation_Graph
;
750 Vertex
: Invocation_Graph_Vertex_Id
);
751 pragma Inline
(Write_Invocation_Graph_Vertex
);
752 -- Write vertex Vertex of invocation graph G to standard output
754 procedure Write_Invocation_Graph_Vertices
(G
: Invocation_Graph
);
755 pragma Inline
(Write_Invocation_Graph_Vertices
);
756 -- Write all vertices of invocation graph G to standard output
758 procedure Write_Statistics
(G
: Invocation_Graph
);
759 pragma Inline
(Write_Statistics
);
760 -- Write the statistical information of invocation graph G to standard
768 (G
: Invocation_Graph
;
769 Edge
: Invocation_Graph_Edge_Id
) renames Write_Invocation_Graph_Edge
;
770 pragma Unreferenced
(pige
);
773 (G
: Invocation_Graph
;
774 Vertex
: Invocation_Graph_Vertex_Id
)
775 renames Write_Invocation_Graph_Vertex
;
776 pragma Unreferenced
(pigv
);
778 ----------------------------
779 -- Write_Elaboration_Root --
780 ----------------------------
782 procedure Write_Elaboration_Root
783 (G
: Invocation_Graph
;
784 Root
: Invocation_Graph_Vertex_Id
)
787 pragma Assert
(Present
(G
));
788 pragma Assert
(Present
(Root
));
790 Write_Str
("elaboration root (IGV_Id_");
791 Write_Int
(Int
(Root
));
792 Write_Str
(") name = ");
793 Write_Name
(Name
(G
, Root
));
795 end Write_Elaboration_Root
;
797 -----------------------------
798 -- Write_Elaboration_Roots --
799 -----------------------------
801 procedure Write_Elaboration_Roots
(G
: Invocation_Graph
) is
802 pragma Assert
(Present
(G
));
804 Num_Of_Roots
: constant Natural := Number_Of_Elaboration_Roots
(G
);
806 Iter
: Elaboration_Root_Iterator
;
807 Root
: Invocation_Graph_Vertex_Id
;
810 Write_Str
("Elaboration roots: ");
811 Write_Int
(Int
(Num_Of_Roots
));
814 if Num_Of_Roots
> 0 then
815 Iter
:= Iterate_Elaboration_Roots
(G
);
816 while Has_Next
(Iter
) loop
819 Write_Elaboration_Root
(G
, Root
);
824 end Write_Elaboration_Roots
;
826 ----------------------------
827 -- Write_Invocation_Graph --
828 ----------------------------
830 procedure Write_Invocation_Graph
(G
: Invocation_Graph
) is
832 pragma Assert
(Present
(G
));
834 -- Nothing to do when switch -d_I (output invocation graph) is not in
837 if not Debug_Flag_Underscore_II
then
841 Write_Str
("Invocation Graph");
845 Write_Statistics
(G
);
846 Write_Invocation_Graph_Vertices
(G
);
847 Write_Elaboration_Roots
(G
);
849 Write_Str
("Invocation Graph end");
853 end Write_Invocation_Graph
;
855 ---------------------------------
856 -- Write_Invocation_Graph_Edge --
857 ---------------------------------
859 procedure Write_Invocation_Graph_Edge
860 (G
: Invocation_Graph
;
861 Edge
: Invocation_Graph_Edge_Id
)
863 pragma Assert
(Present
(G
));
864 pragma Assert
(Present
(Edge
));
866 Targ
: constant Invocation_Graph_Vertex_Id
:= Target
(G
, Edge
);
869 Write_Str
(" invocation graph edge (IGE_Id_");
870 Write_Int
(Int
(Edge
));
874 Write_Str
(" Relation (IR_Id_");
875 Write_Int
(Int
(Relation
(G
, Edge
)));
879 Write_Str
(" Target (IGV_Id_");
880 Write_Int
(Int
(Targ
));
881 Write_Str
(") name = ");
882 Write_Name
(Name
(G
, Targ
));
886 end Write_Invocation_Graph_Edge
;
888 ----------------------------------
889 -- Write_Invocation_Graph_Edges --
890 ----------------------------------
892 procedure Write_Invocation_Graph_Edges
893 (G
: Invocation_Graph
;
894 Vertex
: Invocation_Graph_Vertex_Id
)
896 pragma Assert
(Present
(G
));
897 pragma Assert
(Present
(Vertex
));
899 Num_Of_Edges
: constant Natural :=
900 Number_Of_Edges_To_Targets
(G
, Vertex
);
902 Edge
: Invocation_Graph_Edge_Id
;
903 Iter
: Invocation_Graphs
.Edges_To_Targets_Iterator
;
906 Write_Str
(" Edges to targets: ");
907 Write_Int
(Int
(Num_Of_Edges
));
910 if Num_Of_Edges
> 0 then
911 Iter
:= Iterate_Edges_To_Targets
(G
, Vertex
);
912 while Has_Next
(Iter
) loop
915 Write_Invocation_Graph_Edge
(G
, Edge
);
920 end Write_Invocation_Graph_Edges
;
922 -----------------------------------
923 -- Write_Invocation_Graph_Vertex --
924 -----------------------------------
926 procedure Write_Invocation_Graph_Vertex
927 (G
: Invocation_Graph
;
928 Vertex
: Invocation_Graph_Vertex_Id
)
930 Lib_Graph
: constant Library_Graph
:= Get_Lib_Graph
(G
);
932 B
: constant Library_Graph_Vertex_Id
:= Body_Vertex
(G
, Vertex
);
933 S
: constant Library_Graph_Vertex_Id
:= Spec_Vertex
(G
, Vertex
);
935 pragma Assert
(Present
(G
));
936 pragma Assert
(Present
(Vertex
));
938 Write_Str
("invocation graph vertex (IGV_Id_");
939 Write_Int
(Int
(Vertex
));
940 Write_Str
(") name = ");
941 Write_Name
(Name
(G
, Vertex
));
944 Write_Str
(" Body_Vertex (LGV_Id_");
946 Write_Str
(") name = ");
947 Write_Name
(Name
(Lib_Graph
, B
));
950 Write_Str
(" Construct (IC_Id_");
951 Write_Int
(Int
(Construct
(G
, Vertex
)));
955 Write_Str
(" Spec_Vertex (LGV_Id_");
957 Write_Str
(") name = ");
958 Write_Name
(Name
(Lib_Graph
, S
));
961 Write_Invocation_Graph_Edges
(G
, Vertex
);
962 end Write_Invocation_Graph_Vertex
;
964 -------------------------------------
965 -- Write_Invocation_Graph_Vertices --
966 -------------------------------------
968 procedure Write_Invocation_Graph_Vertices
(G
: Invocation_Graph
) is
969 Iter
: Invocation_Graphs
.All_Vertex_Iterator
;
970 Vertex
: Invocation_Graph_Vertex_Id
;
973 pragma Assert
(Present
(G
));
975 Iter
:= Iterate_All_Vertices
(G
);
976 while Has_Next
(Iter
) loop
979 Write_Invocation_Graph_Vertex
(G
, Vertex
);
981 end Write_Invocation_Graph_Vertices
;
983 ----------------------
984 -- Write_Statistics --
985 ----------------------
987 procedure Write_Statistics
(G
: Invocation_Graph
) is
989 pragma Assert
(Present
(G
));
991 Write_Str
("Edges : ");
992 Write_Num
(Int
(Number_Of_Edges
(G
)));
995 Write_Str
("Roots : ");
996 Write_Num
(Int
(Number_Of_Elaboration_Roots
(G
)));
999 Write_Str
("Vertices: ");
1000 Write_Num
(Int
(Number_Of_Vertices
(G
)));
1004 for Kind
in Invocation_Kind
'Range loop
1006 Write_Num
(Int
(Invocation_Graph_Edge_Count
(G
, Kind
)));
1008 Write_Str
(Kind
'Img);
1013 end Write_Statistics
;
1014 end Invocation_Graph_Writers
;
1016 ---------------------------
1017 -- Library_Graph_Writers --
1018 ---------------------------
1020 package body Library_Graph_Writers
is
1022 -----------------------
1023 -- Local subprograms --
1024 -----------------------
1026 procedure Write_Component
1028 Comp
: Component_Id
);
1029 pragma Inline
(Write_Component
);
1030 -- Write component Comp of library graph G to standard output
1032 procedure Write_Component_Vertices
1034 Comp
: Component_Id
);
1035 pragma Inline
(Write_Component_Vertices
);
1036 -- Write all vertices of component Comp of library graph G to standard
1039 procedure Write_Components
(G
: Library_Graph
);
1040 pragma Inline
(Write_Components
);
1041 -- Write all components of library graph G to standard output
1043 procedure Write_Edges_To_Successors
1045 Vertex
: Library_Graph_Vertex_Id
);
1046 pragma Inline
(Write_Edges_To_Successors
);
1047 -- Write all edges to successors of predecessor Vertex of library graph
1048 -- G to standard output.
1050 procedure Write_Library_Graph_Edge
1052 Edge
: Library_Graph_Edge_Id
);
1053 pragma Inline
(Write_Library_Graph_Edge
);
1054 -- Write edge Edge of library graph G to standard output
1056 procedure Write_Library_Graph_Vertex
1058 Vertex
: Library_Graph_Vertex_Id
);
1059 pragma Inline
(Write_Library_Graph_Vertex
);
1060 -- Write vertex Vertex of library graph G to standard output
1062 procedure Write_Library_Graph_Vertices
(G
: Library_Graph
);
1063 pragma Inline
(Write_Library_Graph_Vertices
);
1064 -- Write all vertices of library graph G to standard output
1066 procedure Write_Statistics
(G
: Library_Graph
);
1067 pragma Inline
(Write_Statistics
);
1068 -- Write the statistical information of library graph G to standard
1077 Comp
: Component_Id
) renames Write_Component
;
1078 pragma Unreferenced
(pc
);
1082 Edge
: Library_Graph_Edge_Id
) renames Write_Library_Graph_Edge
;
1083 pragma Unreferenced
(plge
);
1087 Vertex
: Library_Graph_Vertex_Id
) renames Write_Library_Graph_Vertex
;
1088 pragma Unreferenced
(plgv
);
1090 ---------------------
1091 -- Write_Component --
1092 ---------------------
1094 procedure Write_Component
1096 Comp
: Component_Id
)
1099 pragma Assert
(Present
(G
));
1100 pragma Assert
(Present
(Comp
));
1102 Write_Str
("component (Comp_");
1103 Write_Int
(Int
(Comp
));
1107 Write_Str
(" Pending_Strong_Predecessors = ");
1108 Write_Int
(Int
(Pending_Strong_Predecessors
(G
, Comp
)));
1111 Write_Str
(" Pending_Weak_Predecessors = ");
1112 Write_Int
(Int
(Pending_Weak_Predecessors
(G
, Comp
)));
1115 Write_Component_Vertices
(G
, Comp
);
1118 end Write_Component
;
1120 ------------------------------
1121 -- Write_Component_Vertices --
1122 ------------------------------
1124 procedure Write_Component_Vertices
1126 Comp
: Component_Id
)
1128 pragma Assert
(Present
(G
));
1129 pragma Assert
(Present
(Comp
));
1131 Num_Of_Vertices
: constant Natural :=
1132 Number_Of_Component_Vertices
(G
, Comp
);
1134 Iter
: Component_Vertex_Iterator
;
1135 Vertex
: Library_Graph_Vertex_Id
;
1138 Write_Str
(" Vertices: ");
1139 Write_Int
(Int
(Num_Of_Vertices
));
1142 if Num_Of_Vertices
> 0 then
1143 Iter
:= Iterate_Component_Vertices
(G
, Comp
);
1144 while Has_Next
(Iter
) loop
1145 Next
(Iter
, Vertex
);
1147 Write_Str
(" library graph vertex (LGV_Id_");
1148 Write_Int
(Int
(Vertex
));
1149 Write_Str
(") name = ");
1150 Write_Name
(Name
(G
, Vertex
));
1156 end Write_Component_Vertices
;
1158 ----------------------
1159 -- Write_Components --
1160 ----------------------
1162 procedure Write_Components
(G
: Library_Graph
) is
1163 pragma Assert
(Present
(G
));
1165 Num_Of_Comps
: constant Natural := Number_Of_Components
(G
);
1167 Comp
: Component_Id
;
1168 Iter
: Component_Iterator
;
1171 -- Nothing to do when switch -d_L (output library item graph) is not
1174 if not Debug_Flag_Underscore_LL
then
1178 Write_Str
("Library Graph components");
1182 if Num_Of_Comps
> 0 then
1183 Write_Str
("Components: ");
1184 Write_Num
(Int
(Num_Of_Comps
));
1187 Iter
:= Iterate_Components
(G
);
1188 while Has_Next
(Iter
) loop
1191 Write_Component
(G
, Comp
);
1197 Write_Str
("Library Graph components end");
1201 end Write_Components
;
1203 -------------------------------
1204 -- Write_Edges_To_Successors --
1205 -------------------------------
1207 procedure Write_Edges_To_Successors
1209 Vertex
: Library_Graph_Vertex_Id
)
1211 pragma Assert
(Present
(G
));
1212 pragma Assert
(Present
(Vertex
));
1214 Num_Of_Edges
: constant Natural :=
1215 Number_Of_Edges_To_Successors
(G
, Vertex
);
1217 Edge
: Library_Graph_Edge_Id
;
1218 Iter
: Edges_To_Successors_Iterator
;
1221 Write_Str
(" Edges to successors: ");
1222 Write_Int
(Int
(Num_Of_Edges
));
1225 if Num_Of_Edges
> 0 then
1226 Iter
:= Iterate_Edges_To_Successors
(G
, Vertex
);
1227 while Has_Next
(Iter
) loop
1230 Write_Library_Graph_Edge
(G
, Edge
);
1235 end Write_Edges_To_Successors
;
1237 -------------------------
1238 -- Write_Library_Graph --
1239 -------------------------
1241 procedure Write_Library_Graph
(G
: Library_Graph
) is
1243 pragma Assert
(Present
(G
));
1245 -- Nothing to do when switch -d_L (output library item graph) is not
1248 if not Debug_Flag_Underscore_LL
then
1252 Write_Str
("Library Graph");
1256 Write_Statistics
(G
);
1257 Write_Library_Graph_Vertices
(G
);
1258 Write_Components
(G
);
1260 Write_Str
("Library Graph end");
1264 end Write_Library_Graph
;
1266 ------------------------------
1267 -- Write_Library_Graph_Edge --
1268 ------------------------------
1270 procedure Write_Library_Graph_Edge
1272 Edge
: Library_Graph_Edge_Id
)
1274 pragma Assert
(Present
(G
));
1275 pragma Assert
(Present
(Edge
));
1277 Pred
: constant Library_Graph_Vertex_Id
:= Predecessor
(G
, Edge
);
1278 Succ
: constant Library_Graph_Vertex_Id
:= Successor
(G
, Edge
);
1281 Write_Str
(" library graph edge (LGE_Id_");
1282 Write_Int
(Int
(Edge
));
1286 Write_Str
(" Kind = ");
1287 Write_Str
(Kind
(G
, Edge
)'Img);
1290 Write_Str
(" Predecessor (LGV_Id_");
1291 Write_Int
(Int
(Pred
));
1292 Write_Str
(") name = ");
1293 Write_Name
(Name
(G
, Pred
));
1296 Write_Str
(" Successor (LGV_Id_");
1297 Write_Int
(Int
(Succ
));
1298 Write_Str
(") name = ");
1299 Write_Name
(Name
(G
, Succ
));
1303 end Write_Library_Graph_Edge
;
1305 --------------------------------
1306 -- Write_Library_Graph_Vertex --
1307 --------------------------------
1309 procedure Write_Library_Graph_Vertex
1311 Vertex
: Library_Graph_Vertex_Id
)
1313 pragma Assert
(Present
(G
));
1314 pragma Assert
(Present
(Vertex
));
1316 Item
: constant Library_Graph_Vertex_Id
:=
1317 Corresponding_Item
(G
, Vertex
);
1318 U_Id
: constant Unit_Id
:= Unit
(G
, Vertex
);
1321 Write_Str
("library graph vertex (LGV_Id_");
1322 Write_Int
(Int
(Vertex
));
1323 Write_Str
(") name = ");
1324 Write_Name
(Name
(G
, Vertex
));
1327 if Present
(Item
) then
1328 Write_Str
(" Corresponding_Item (LGV_Id_");
1329 Write_Int
(Int
(Item
));
1330 Write_Str
(") name = ");
1331 Write_Name
(Name
(G
, Item
));
1333 Write_Str
(" Corresponding_Item = none");
1337 Write_Str
(" In_Elaboration_Order = ");
1339 if In_Elaboration_Order
(G
, Vertex
) then
1342 Write_Str
("False");
1346 Write_Str
(" Pending_Strong_Predecessors = ");
1347 Write_Int
(Int
(Pending_Strong_Predecessors
(G
, Vertex
)));
1350 Write_Str
(" Pending_Weak_Predecessors = ");
1351 Write_Int
(Int
(Pending_Weak_Predecessors
(G
, Vertex
)));
1354 Write_Str
(" Component (Comp_Id_");
1355 Write_Int
(Int
(Component
(G
, Vertex
)));
1359 Write_Str
(" Unit (U_Id_");
1360 Write_Int
(Int
(U_Id
));
1361 Write_Str
(") name = ");
1362 Write_Name
(Name
(U_Id
));
1365 Write_Edges_To_Successors
(G
, Vertex
);
1366 end Write_Library_Graph_Vertex
;
1368 ----------------------------------
1369 -- Write_Library_Graph_Vertices --
1370 ----------------------------------
1372 procedure Write_Library_Graph_Vertices
(G
: Library_Graph
) is
1373 Iter
: Library_Graphs
.All_Vertex_Iterator
;
1374 Vertex
: Library_Graph_Vertex_Id
;
1377 pragma Assert
(Present
(G
));
1379 Iter
:= Iterate_All_Vertices
(G
);
1380 while Has_Next
(Iter
) loop
1381 Next
(Iter
, Vertex
);
1383 Write_Library_Graph_Vertex
(G
, Vertex
);
1385 end Write_Library_Graph_Vertices
;
1387 ----------------------
1388 -- Write_Statistics --
1389 ----------------------
1391 procedure Write_Statistics
(G
: Library_Graph
) is
1393 Write_Str
("Components: ");
1394 Write_Num
(Int
(Number_Of_Components
(G
)));
1397 Write_Str
("Edges : ");
1398 Write_Num
(Int
(Number_Of_Edges
(G
)));
1401 Write_Str
("Vertices : ");
1402 Write_Num
(Int
(Number_Of_Vertices
(G
)));
1406 for Kind
in Library_Graph_Edge_Kind
'Range loop
1408 Write_Num
(Int
(Library_Graph_Edge_Count
(G
, Kind
)));
1410 Write_Str
(Kind
'Img);
1415 end Write_Statistics
;
1416 end Library_Graph_Writers
;
1422 package body Phase_Writers
is
1424 subtype Phase_Message
is String (1 .. 32);
1426 -- The following table contains the phase-specific messages for phase
1429 End_Messages
: constant array (Elaboration_Phase
) of Phase_Message
:=
1430 (Component_Discovery
=> "components discovered. ",
1431 Cycle_Diagnostics
=> "cycle diagnosed. ",
1432 Cycle_Discovery
=> "cycles discovered. ",
1433 Cycle_Validation
=> "cycles validated. ",
1434 Elaboration_Order_Validation
=> "elaboration order validated. ",
1435 Invocation_Graph_Construction
=> "invocation graph constructed. ",
1436 Invocation_Graph_Validation
=> "invocation graph validated. ",
1437 Library_Graph_Augmentation
=> "library graph augmented. ",
1438 Library_Graph_Construction
=> "library graph constructed. ",
1439 Library_Graph_Elaboration
=> "library graph elaborated. ",
1440 Library_Graph_Validation
=> "library graph validated. ",
1441 Unit_Collection
=> "units collected. ",
1442 Unit_Elaboration
=> "units elaborated. ");
1444 -- The following table contains the phase-specific messages for phase
1447 Start_Messages
: constant array (Elaboration_Phase
) of Phase_Message
:=
1448 (Component_Discovery
=> "discovering components... ",
1449 Cycle_Diagnostics
=> "diagnosing cycle... ",
1450 Cycle_Discovery
=> "discovering cycles... ",
1451 Cycle_Validation
=> "validating cycles... ",
1452 Elaboration_Order_Validation
=> "validating elaboration order... ",
1453 Invocation_Graph_Construction
=> "constructing invocation graph...",
1454 Invocation_Graph_Validation
=> "validating invocation graph... ",
1455 Library_Graph_Augmentation
=> "augmenting library graph... ",
1456 Library_Graph_Construction
=> "constructing library graph... ",
1457 Library_Graph_Elaboration
=> "elaborating library graph... ",
1458 Library_Graph_Validation
=> "validating library graph... ",
1459 Unit_Collection
=> "collecting units... ",
1460 Unit_Elaboration
=> "elaborating units... ");
1462 -----------------------
1463 -- Local subprograms --
1464 -----------------------
1466 procedure Write_Phase_Message
(Msg
: Phase_Message
);
1467 pragma Inline
(Write_Phase_Message
);
1468 -- Write elaboration phase-related message Msg to standard output
1474 procedure End_Phase
(Phase
: Elaboration_Phase
) is
1476 Write_Phase_Message
(End_Messages
(Phase
));
1483 procedure Start_Phase
(Phase
: Elaboration_Phase
) is
1485 Write_Phase_Message
(Start_Messages
(Phase
));
1488 -------------------------
1489 -- Write_Phase_Message --
1490 -------------------------
1492 procedure Write_Phase_Message
(Msg
: Phase_Message
) is
1494 -- Nothing to do when switch -d_S (output elaboration order status)
1495 -- is not in effect.
1497 if not Debug_Flag_Underscore_SS
then
1503 end Write_Phase_Message
;
1506 --------------------------
1507 -- Unit_Closure_Writers --
1508 --------------------------
1510 package body Unit_Closure_Writers
is
1511 function Hash_File_Name
(Nam
: File_Name_Type
) return Bucket_Range_Type
;
1512 pragma Inline
(Hash_File_Name
);
1513 -- Obtain the hash value of key Nam
1515 package File_Name_Tables
is new Membership_Sets
1516 (Element_Type
=> File_Name_Type
,
1518 Hash
=> Hash_File_Name
);
1519 use File_Name_Tables
;
1521 -----------------------
1522 -- Local subprograms --
1523 -----------------------
1525 procedure Write_File_Name
(Nam
: File_Name_Type
);
1526 pragma Inline
(Write_File_Name
);
1527 -- Write file name Nam to standard output
1529 procedure Write_Subunit_Closure
1531 Set
: Membership_Set
);
1532 pragma Inline
(Write_Subunit_Closure
);
1533 -- Write the subunit which corresponds to dependency Dep to standard
1534 -- output if it does not appear in set Set.
1536 procedure Write_Subunits_Closure
(Set
: Membership_Set
);
1537 pragma Inline
(Write_Subunits_Closure
);
1538 -- Write all subunits to standard output if they do not appear in set
1541 procedure Write_Unit_Closure
1543 Set
: Membership_Set
);
1544 pragma Inline
(Write_Unit_Closure
);
1545 -- Write unit U_Id to standard output if it does not appear in set Set
1547 procedure Write_Units_Closure
1548 (Order
: Unit_Id_Table
;
1549 Set
: Membership_Set
);
1550 pragma Inline
(Write_Units_Closure
);
1551 -- Write all units of elaboration order Order to standard output if they
1552 -- do not appear in set Set.
1554 --------------------
1555 -- Hash_File_Name --
1556 --------------------
1558 function Hash_File_Name
1559 (Nam
: File_Name_Type
) return Bucket_Range_Type
1562 pragma Assert
(Present
(Nam
));
1564 return Bucket_Range_Type
(abs Nam
);
1567 ---------------------
1568 -- Write_File_Name --
1569 ---------------------
1571 procedure Write_File_Name
(Nam
: File_Name_Type
) is
1572 Use_Formatting
: constant Boolean := not Zero_Formatting
;
1575 pragma Assert
(Present
(Nam
));
1577 if Use_Formatting
then
1581 Write_Line
(Get_Name_String
(Nam
));
1582 end Write_File_Name
;
1584 ---------------------------
1585 -- Write_Subunit_Closure --
1586 ---------------------------
1588 procedure Write_Subunit_Closure
1590 Set
: Membership_Set
)
1592 pragma Assert
(Present
(Dep
));
1593 pragma Assert
(Present
(Set
));
1595 Dep_Rec
: Sdep_Record
renames Sdep
.Table
(Dep
);
1596 Source
: constant File_Name_Type
:= Dep_Rec
.Sfile
;
1598 pragma Assert
(Present
(Source
));
1601 -- Nothing to do when the source file has already been written
1603 if Contains
(Set
, Source
) then
1606 -- Nothing to do when the source file does not denote a non-internal
1609 elsif not Present
(Dep_Rec
.Subunit_Name
)
1610 or else Is_Internal_File_Name
(Source
)
1615 -- Mark the subunit as written
1617 Insert
(Set
, Source
);
1618 Write_File_Name
(Source
);
1619 end Write_Subunit_Closure
;
1621 ----------------------------
1622 -- Write_Subunits_Closure --
1623 ----------------------------
1625 procedure Write_Subunits_Closure
(Set
: Membership_Set
) is
1627 pragma Assert
(Present
(Set
));
1629 for Dep
in Sdep
.First
.. Sdep
.Last
loop
1630 Write_Subunit_Closure
(Dep
, Set
);
1632 end Write_Subunits_Closure
;
1634 ------------------------
1635 -- Write_Unit_Closure --
1636 ------------------------
1638 procedure Write_Unit_Closure
(Order
: Unit_Id_Table
) is
1639 Use_Formatting
: constant Boolean := not Zero_Formatting
;
1641 Set
: Membership_Set
;
1644 -- Nothing to do when switch -R (list sources referenced in closure)
1645 -- is not in effect.
1647 if not List_Closure
then
1651 if Use_Formatting
then
1653 Write_Line
("REFERENCED SOURCES");
1656 -- Use a set to avoid writing duplicate units and subunits
1658 Set
:= Create
(Number_Of_Elaborable_Units
);
1660 Write_Units_Closure
(Order
, Set
);
1661 Write_Subunits_Closure
(Set
);
1665 if Use_Formatting
then
1668 end Write_Unit_Closure
;
1670 ------------------------
1671 -- Write_Unit_Closure --
1672 ------------------------
1674 procedure Write_Unit_Closure
1676 Set
: Membership_Set
)
1678 pragma Assert
(Present
(U_Id
));
1679 pragma Assert
(Present
(Set
));
1681 U_Rec
: Unit_Record
renames ALI
.Units
.Table
(U_Id
);
1682 Source
: constant File_Name_Type
:= U_Rec
.Sfile
;
1684 pragma Assert
(Present
(Source
));
1687 -- Nothing to do when the source file has already been written
1689 if Contains
(Set
, Source
) then
1692 -- Nothing to do for internal source files unless switch -Ra is in
1695 elsif Is_Internal_File_Name
(Source
)
1696 and then not List_Closure_All
1701 -- Mark the source file as written
1703 Insert
(Set
, Source
);
1704 Write_File_Name
(Source
);
1705 end Write_Unit_Closure
;
1707 -------------------------
1708 -- Write_Units_Closure --
1709 -------------------------
1711 procedure Write_Units_Closure
1712 (Order
: Unit_Id_Table
;
1713 Set
: Membership_Set
)
1716 pragma Assert
(Present
(Set
));
1718 for Index
in reverse Unit_Id_Tables
.First
..
1719 Unit_Id_Tables
.Last
(Order
)
1722 (U_Id
=> Order
.Table
(Index
),
1725 end Write_Units_Closure
;
1726 end Unit_Closure_Writers
;
1734 Val_Indent
: Indentation_Level
:= Number_Column
)
1736 function Digits_Indentation
return Indentation_Level
;
1737 pragma Inline
(Digits_Indentation
);
1738 -- Determine the level of indentation the number requires in order to
1739 -- be right-justified by Val_Indent.
1741 ------------------------
1742 -- Digits_Indentation --
1743 ------------------------
1745 function Digits_Indentation
return Indentation_Level
is
1746 Indent
: Indentation_Level
;
1750 -- Treat zero as a single digit
1759 -- Shrink the input value by dividing it until all of its digits
1763 Indent
:= Indent
+ 1;
1768 return Val_Indent
- Indent
;
1769 end Digits_Indentation
;
1771 -- Start of processing for Write_Num
1774 Indent_By
(Digits_Indentation
);