1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- B I N D O . V A L I D A T O 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 Debug
; use Debug
;
27 with Output
; use Output
;
28 with Types
; use Types
;
35 use Bindo
.Writers
.Phase_Writers
;
37 package body Bindo
.Validators
is
39 -----------------------
40 -- Local subprograms --
41 -----------------------
46 pragma Inline
(Write_Error
);
47 -- Write error message Msg to standard output and set flag Flag to True
49 ----------------------
50 -- Cycle_Validators --
51 ----------------------
53 package body Cycle_Validators
is
54 Has_Invalid_Cycle
: Boolean := False;
55 -- Flag set when the library graph contains an invalid cycle
57 -----------------------
58 -- Local subprograms --
59 -----------------------
61 procedure Validate_Cycle
63 Cycle
: Library_Graph_Cycle_Id
);
64 pragma Inline
(Validate_Cycle
);
65 -- Ensure that a cycle meets the following requirements:
67 -- * Is of proper kind
68 -- * Has enough edges to form a circuit
69 -- * No edge is repeated
71 procedure Validate_Cycle_Path
73 Cycle
: Library_Graph_Cycle_Id
);
74 pragma Inline
(Validate_Cycle_Path
);
75 -- Ensure that the path of a cycle meets the following requirements:
77 -- * No edge is repeated
83 procedure Validate_Cycle
85 Cycle
: Library_Graph_Cycle_Id
)
87 Msg
: constant String := "Validate_Cycle";
90 pragma Assert
(Present
(G
));
92 if not Present
(Cycle
) then
93 Write_Error
(Msg
, Has_Invalid_Cycle
);
95 Write_Str
(" empty cycle");
101 if Kind
(G
, Cycle
) = No_Cycle_Kind
then
102 Write_Error
(Msg
, Has_Invalid_Cycle
);
104 Write_Str
(" cycle (LGC_Id_");
105 Write_Int
(Int
(Cycle
));
106 Write_Str
(") is a No_Cycle");
111 -- A cycle requires at least one edge (self cycle) to form a circuit
113 if Length
(G
, Cycle
) < 1 then
114 Write_Error
(Msg
, Has_Invalid_Cycle
);
116 Write_Str
(" cycle (LGC_Id_");
117 Write_Int
(Int
(Cycle
));
118 Write_Str
(") does not contain enough edges");
123 Validate_Cycle_Path
(G
, Cycle
);
126 -------------------------
127 -- Validate_Cycle_Path --
128 -------------------------
130 procedure Validate_Cycle_Path
132 Cycle
: Library_Graph_Cycle_Id
)
134 Msg
: constant String := "Validate_Cycle_Path";
136 Edge
: Library_Graph_Edge_Id
;
137 Edges
: LGE_Sets
.Membership_Set
;
138 Iter
: Edges_Of_Cycle_Iterator
;
141 pragma Assert
(Present
(G
));
142 pragma Assert
(Present
(Cycle
));
144 -- Use a set to detect duplicate edges while traversing the cycle
146 Edges
:= LGE_Sets
.Create
(Length
(G
, Cycle
));
148 -- Inspect the edges of the cycle, trying to catch duplicates
150 Iter
:= Iterate_Edges_Of_Cycle
(G
, Cycle
);
151 while Has_Next
(Iter
) loop
154 -- The current edge has already been encountered while traversing
155 -- the cycle. This indicates that the cycle is malformed as edges
156 -- are not repeated in the circuit.
158 if LGE_Sets
.Contains
(Edges
, Edge
) then
159 Write_Error
(Msg
, Has_Invalid_Cycle
);
161 Write_Str
(" library graph edge (LGE_Id_");
162 Write_Int
(Int
(Edge
));
163 Write_Str
(") is repeated in cycle (LGC_Id_");
164 Write_Int
(Int
(Cycle
));
168 -- Otherwise add the current edge to the set of encountered edges
171 LGE_Sets
.Insert
(Edges
, Edge
);
175 LGE_Sets
.Destroy
(Edges
);
176 end Validate_Cycle_Path
;
178 ---------------------
179 -- Validate_Cycles --
180 ---------------------
182 procedure Validate_Cycles
(G
: Library_Graph
) is
183 Cycle
: Library_Graph_Cycle_Id
;
184 Iter
: All_Cycle_Iterator
;
187 pragma Assert
(Present
(G
));
189 -- Nothing to do when switch -d_V (validate bindo cycles, graphs, and
190 -- order) is not in effect.
192 if not Debug_Flag_Underscore_VV
then
196 Start_Phase
(Cycle_Validation
);
198 Iter
:= Iterate_All_Cycles
(G
);
199 while Has_Next
(Iter
) loop
202 Validate_Cycle
(G
, Cycle
);
205 End_Phase
(Cycle_Validation
);
207 if Has_Invalid_Cycle
then
211 end Cycle_Validators
;
213 ----------------------------------
214 -- Elaboration_Order_Validators --
215 ----------------------------------
217 package body Elaboration_Order_Validators
is
218 Has_Invalid_Data
: Boolean := False;
219 -- Flag set when the elaboration order contains invalid data
221 -----------------------
222 -- Local subprograms --
223 -----------------------
225 function Build_Elaborable_Unit_Set
return Unit_Sets
.Membership_Set
;
226 pragma Inline
(Build_Elaborable_Unit_Set
);
227 -- Create a set from all units that need to be elaborated
229 procedure Report_Missing_Elaboration
(U_Id
: Unit_Id
);
230 pragma Inline
(Report_Missing_Elaboration
);
231 -- Emit an error concerning unit U_Id that must be elaborated, but was
234 procedure Report_Missing_Elaborations
(Set
: Unit_Sets
.Membership_Set
);
235 pragma Inline
(Report_Missing_Elaborations
);
236 -- Emit errors on all units in set Set that must be elaborated, but were
239 procedure Report_Spurious_Elaboration
(U_Id
: Unit_Id
);
240 pragma Inline
(Report_Spurious_Elaboration
);
241 -- Emit an error concerning unit U_Id that is incorrectly elaborated
243 procedure Validate_Unit
245 Elab_Set
: Unit_Sets
.Membership_Set
);
246 pragma Inline
(Validate_Unit
);
247 -- Validate the elaboration status of unit U_Id. Elab_Set is the set of
248 -- all units that need to be elaborated.
250 procedure Validate_Units
(Order
: Unit_Id_Table
);
251 pragma Inline
(Validate_Units
);
252 -- Validate all units in elaboration order Order
254 -------------------------------
255 -- Build_Elaborable_Unit_Set --
256 -------------------------------
258 function Build_Elaborable_Unit_Set
return Unit_Sets
.Membership_Set
is
259 Iter
: Elaborable_Units_Iterator
;
260 Set
: Unit_Sets
.Membership_Set
;
264 Set
:= Unit_Sets
.Create
(Number_Of_Elaborable_Units
);
265 Iter
:= Iterate_Elaborable_Units
;
266 while Has_Next
(Iter
) loop
269 Unit_Sets
.Insert
(Set
, U_Id
);
273 end Build_Elaborable_Unit_Set
;
275 --------------------------------
276 -- Report_Missing_Elaboration --
277 --------------------------------
279 procedure Report_Missing_Elaboration
(U_Id
: Unit_Id
) is
280 Msg
: constant String := "Report_Missing_Elaboration";
283 pragma Assert
(Present
(U_Id
));
284 Write_Error
(Msg
, Has_Invalid_Data
);
286 Write_Str
("unit (U_Id_");
287 Write_Int
(Int
(U_Id
));
288 Write_Str
(") name = ");
289 Write_Name
(Name
(U_Id
));
290 Write_Str
(" must be elaborated");
292 end Report_Missing_Elaboration
;
294 ---------------------------------
295 -- Report_Missing_Elaborations --
296 ---------------------------------
298 procedure Report_Missing_Elaborations
(Set
: Unit_Sets
.Membership_Set
) is
299 Iter
: Unit_Sets
.Iterator
;
303 Iter
:= Unit_Sets
.Iterate
(Set
);
304 while Unit_Sets
.Has_Next
(Iter
) loop
305 Unit_Sets
.Next
(Iter
, U_Id
);
307 Report_Missing_Elaboration
(U_Id
);
309 end Report_Missing_Elaborations
;
311 ---------------------------------
312 -- Report_Spurious_Elaboration --
313 ---------------------------------
315 procedure Report_Spurious_Elaboration
(U_Id
: Unit_Id
) is
316 Msg
: constant String := "Report_Spurious_Elaboration";
319 pragma Assert
(Present
(U_Id
));
320 Write_Error
(Msg
, Has_Invalid_Data
);
322 Write_Str
("unit (U_Id_");
323 Write_Int
(Int
(U_Id
));
324 Write_Str
(") name = ");
325 Write_Name
(Name
(U_Id
));
326 Write_Str
(" must not be elaborated");
327 end Report_Spurious_Elaboration
;
329 --------------------------------
330 -- Validate_Elaboration_Order --
331 --------------------------------
333 procedure Validate_Elaboration_Order
(Order
: Unit_Id_Table
) is
335 -- Nothing to do when switch -d_V (validate bindo cycles, graphs, and
336 -- order) is not in effect.
338 if not Debug_Flag_Underscore_VV
then
342 Start_Phase
(Elaboration_Order_Validation
);
344 Validate_Units
(Order
);
346 End_Phase
(Elaboration_Order_Validation
);
348 if Has_Invalid_Data
then
349 raise Invalid_Elaboration_Order
;
351 end Validate_Elaboration_Order
;
357 procedure Validate_Unit
359 Elab_Set
: Unit_Sets
.Membership_Set
)
362 pragma Assert
(Present
(U_Id
));
364 -- The current unit in the elaboration order appears within the set
365 -- of units that require elaboration. Remove it from the set.
367 if Unit_Sets
.Contains
(Elab_Set
, U_Id
) then
368 Unit_Sets
.Delete
(Elab_Set
, U_Id
);
370 -- Otherwise the current unit in the elaboration order must not be
374 Report_Spurious_Elaboration
(U_Id
);
382 procedure Validate_Units
(Order
: Unit_Id_Table
) is
383 Elab_Set
: Unit_Sets
.Membership_Set
;
386 -- Collect all units in the compilation that need to be elaborated
389 Elab_Set
:= Build_Elaborable_Unit_Set
;
391 -- Validate each unit in the elaboration order against the set of
392 -- units that need to be elaborated.
394 for Index
in Unit_Id_Tables
.First
.. Unit_Id_Tables
.Last
(Order
) loop
396 (U_Id
=> Order
.Table
(Index
),
397 Elab_Set
=> Elab_Set
);
400 -- At this point all units that need to be elaborated should have
401 -- been eliminated from the set. Report any units that are missing
402 -- their elaboration.
404 Report_Missing_Elaborations
(Elab_Set
);
405 Unit_Sets
.Destroy
(Elab_Set
);
407 end Elaboration_Order_Validators
;
409 ---------------------------------
410 -- Invocation_Graph_Validators --
411 ---------------------------------
413 package body Invocation_Graph_Validators
is
414 Has_Invalid_Data
: Boolean := False;
415 -- Flag set when the invocation graph contains invalid data
417 -----------------------
418 -- Local subprograms --
419 -----------------------
421 procedure Validate_Invocation_Graph_Edge
422 (G
: Invocation_Graph
;
423 Edge
: Invocation_Graph_Edge_Id
);
424 pragma Inline
(Validate_Invocation_Graph_Edge
);
425 -- Verify that the attributes of edge Edge of invocation graph G are
428 procedure Validate_Invocation_Graph_Edges
(G
: Invocation_Graph
);
429 pragma Inline
(Validate_Invocation_Graph_Edges
);
430 -- Verify that the attributes of all edges of invocation graph G are
433 procedure Validate_Invocation_Graph_Vertex
434 (G
: Invocation_Graph
;
435 Vertex
: Invocation_Graph_Vertex_Id
);
436 pragma Inline
(Validate_Invocation_Graph_Vertex
);
437 -- Verify that the attributes of vertex Vertex of invocation graph G are
440 procedure Validate_Invocation_Graph_Vertices
(G
: Invocation_Graph
);
441 pragma Inline
(Validate_Invocation_Graph_Vertices
);
442 -- Verify that the attributes of all vertices of invocation graph G are
445 -------------------------------
446 -- Validate_Invocation_Graph --
447 -------------------------------
449 procedure Validate_Invocation_Graph
(G
: Invocation_Graph
) is
451 pragma Assert
(Present
(G
));
453 -- Nothing to do when switch -d_V (validate bindo cycles, graphs, and
454 -- order) is not in effect.
456 if not Debug_Flag_Underscore_VV
then
460 Start_Phase
(Invocation_Graph_Validation
);
462 Validate_Invocation_Graph_Vertices
(G
);
463 Validate_Invocation_Graph_Edges
(G
);
465 End_Phase
(Invocation_Graph_Validation
);
467 if Has_Invalid_Data
then
468 raise Invalid_Invocation_Graph
;
470 end Validate_Invocation_Graph
;
472 ------------------------------------
473 -- Validate_Invocation_Graph_Edge --
474 ------------------------------------
476 procedure Validate_Invocation_Graph_Edge
477 (G
: Invocation_Graph
;
478 Edge
: Invocation_Graph_Edge_Id
)
480 Msg
: constant String := "Validate_Invocation_Graph_Edge";
483 pragma Assert
(Present
(G
));
485 if not Present
(Edge
) then
486 Write_Error
(Msg
, Has_Invalid_Data
);
488 Write_Str
(" empty invocation graph edge");
494 if not Present
(Relation
(G
, Edge
)) then
495 Write_Error
(Msg
, Has_Invalid_Data
);
497 Write_Str
(" invocation graph edge (IGE_Id_");
498 Write_Int
(Int
(Edge
));
499 Write_Str
(") lacks Relation");
504 if not Present
(Target
(G
, Edge
)) then
505 Write_Error
(Msg
, Has_Invalid_Data
);
507 Write_Str
(" invocation graph edge (IGE_Id_");
508 Write_Int
(Int
(Edge
));
509 Write_Str
(") lacks Target");
513 end Validate_Invocation_Graph_Edge
;
515 -------------------------------------
516 -- Validate_Invocation_Graph_Edges --
517 -------------------------------------
519 procedure Validate_Invocation_Graph_Edges
(G
: Invocation_Graph
) is
520 Edge
: Invocation_Graph_Edge_Id
;
521 Iter
: Invocation_Graphs
.All_Edge_Iterator
;
524 pragma Assert
(Present
(G
));
526 Iter
:= Iterate_All_Edges
(G
);
527 while Has_Next
(Iter
) loop
530 Validate_Invocation_Graph_Edge
(G
, Edge
);
532 end Validate_Invocation_Graph_Edges
;
534 --------------------------------------
535 -- Validate_Invocation_Graph_Vertex --
536 --------------------------------------
538 procedure Validate_Invocation_Graph_Vertex
539 (G
: Invocation_Graph
;
540 Vertex
: Invocation_Graph_Vertex_Id
)
542 Msg
: constant String := "Validate_Invocation_Graph_Vertex";
545 pragma Assert
(Present
(G
));
547 if not Present
(Vertex
) then
548 Write_Error
(Msg
, Has_Invalid_Data
);
550 Write_Str
(" empty invocation graph vertex");
556 if not Present
(Body_Vertex
(G
, Vertex
)) then
557 Write_Error
(Msg
, Has_Invalid_Data
);
559 Write_Str
(" invocation graph vertex (IGV_Id_");
560 Write_Int
(Int
(Vertex
));
561 Write_Str
(") lacks Body_Vertex");
566 if not Present
(Construct
(G
, Vertex
)) then
567 Write_Error
(Msg
, Has_Invalid_Data
);
569 Write_Str
(" invocation graph vertex (IGV_Id_");
570 Write_Int
(Int
(Vertex
));
571 Write_Str
(") lacks Construct");
576 if not Present
(Spec_Vertex
(G
, Vertex
)) then
577 Write_Error
(Msg
, Has_Invalid_Data
);
579 Write_Str
(" invocation graph vertex (IGV_Id_");
580 Write_Int
(Int
(Vertex
));
581 Write_Str
(") lacks Spec_Vertex");
585 end Validate_Invocation_Graph_Vertex
;
587 ----------------------------------------
588 -- Validate_Invocation_Graph_Vertices --
589 ----------------------------------------
591 procedure Validate_Invocation_Graph_Vertices
(G
: Invocation_Graph
) is
592 Iter
: Invocation_Graphs
.All_Vertex_Iterator
;
593 Vertex
: Invocation_Graph_Vertex_Id
;
596 pragma Assert
(Present
(G
));
598 Iter
:= Iterate_All_Vertices
(G
);
599 while Has_Next
(Iter
) loop
602 Validate_Invocation_Graph_Vertex
(G
, Vertex
);
604 end Validate_Invocation_Graph_Vertices
;
605 end Invocation_Graph_Validators
;
607 ------------------------------
608 -- Library_Graph_Validators --
609 ------------------------------
611 package body Library_Graph_Validators
is
612 Has_Invalid_Data
: Boolean := False;
613 -- Flag set when the library graph contains invalid data
615 -----------------------
616 -- Local subprograms --
617 -----------------------
619 procedure Validate_Library_Graph_Edge
621 Edge
: Library_Graph_Edge_Id
);
622 pragma Inline
(Validate_Library_Graph_Edge
);
623 -- Verify that the attributes of edge Edge of library graph G are
626 procedure Validate_Library_Graph_Edges
(G
: Library_Graph
);
627 pragma Inline
(Validate_Library_Graph_Edges
);
628 -- Verify that the attributes of all edges of library graph G are
631 procedure Validate_Library_Graph_Vertex
633 Vertex
: Library_Graph_Vertex_Id
);
634 pragma Inline
(Validate_Library_Graph_Vertex
);
635 -- Verify that the attributes of vertex Vertex of library graph G are
638 procedure Validate_Library_Graph_Vertices
(G
: Library_Graph
);
639 pragma Inline
(Validate_Library_Graph_Vertices
);
640 -- Verify that the attributes of all vertices of library graph G are
643 ----------------------------
644 -- Validate_Library_Graph --
645 ----------------------------
647 procedure Validate_Library_Graph
(G
: Library_Graph
) is
649 pragma Assert
(Present
(G
));
651 -- Nothing to do when switch -d_V (validate bindo cycles, graphs, and
652 -- order) is not in effect.
654 if not Debug_Flag_Underscore_VV
then
658 Start_Phase
(Library_Graph_Validation
);
660 Validate_Library_Graph_Vertices
(G
);
661 Validate_Library_Graph_Edges
(G
);
663 End_Phase
(Library_Graph_Validation
);
665 if Has_Invalid_Data
then
666 raise Invalid_Library_Graph
;
668 end Validate_Library_Graph
;
670 ---------------------------------
671 -- Validate_Library_Graph_Edge --
672 ---------------------------------
674 procedure Validate_Library_Graph_Edge
676 Edge
: Library_Graph_Edge_Id
)
678 Msg
: constant String := "Validate_Library_Graph_Edge";
681 pragma Assert
(Present
(G
));
683 if not Present
(Edge
) then
684 Write_Error
(Msg
, Has_Invalid_Data
);
686 Write_Str
(" empty library graph edge");
692 if Kind
(G
, Edge
) = No_Edge
then
693 Write_Error
(Msg
, Has_Invalid_Data
);
695 Write_Str
(" library graph edge (LGE_Id_");
696 Write_Int
(Int
(Edge
));
697 Write_Str
(") is not a valid edge");
701 elsif Kind
(G
, Edge
) = Body_Before_Spec_Edge
then
702 Write_Error
(Msg
, Has_Invalid_Data
);
704 Write_Str
(" library graph edge (LGE_Id_");
705 Write_Int
(Int
(Edge
));
706 Write_Str
(") is a Body_Before_Spec edge");
711 if not Present
(Predecessor
(G
, Edge
)) then
712 Write_Error
(Msg
, Has_Invalid_Data
);
714 Write_Str
(" library graph edge (LGE_Id_");
715 Write_Int
(Int
(Edge
));
716 Write_Str
(") lacks Predecessor");
721 if not Present
(Successor
(G
, Edge
)) then
722 Write_Error
(Msg
, Has_Invalid_Data
);
724 Write_Str
(" library graph edge (LGE_Id_");
725 Write_Int
(Int
(Edge
));
726 Write_Str
(") lacks Successor");
730 end Validate_Library_Graph_Edge
;
732 ----------------------------------
733 -- Validate_Library_Graph_Edges --
734 ----------------------------------
736 procedure Validate_Library_Graph_Edges
(G
: Library_Graph
) is
737 Edge
: Library_Graph_Edge_Id
;
738 Iter
: Library_Graphs
.All_Edge_Iterator
;
741 pragma Assert
(Present
(G
));
743 Iter
:= Iterate_All_Edges
(G
);
744 while Has_Next
(Iter
) loop
747 Validate_Library_Graph_Edge
(G
, Edge
);
749 end Validate_Library_Graph_Edges
;
751 -----------------------------------
752 -- Validate_Library_Graph_Vertex --
753 -----------------------------------
755 procedure Validate_Library_Graph_Vertex
757 Vertex
: Library_Graph_Vertex_Id
)
759 Msg
: constant String := "Validate_Library_Graph_Vertex";
762 pragma Assert
(Present
(G
));
764 if not Present
(Vertex
) then
765 Write_Error
(Msg
, Has_Invalid_Data
);
767 Write_Str
(" empty library graph vertex");
773 if (Is_Body_With_Spec
(G
, Vertex
)
775 Is_Spec_With_Body
(G
, Vertex
))
776 and then not Present
(Corresponding_Item
(G
, Vertex
))
778 Write_Error
(Msg
, Has_Invalid_Data
);
780 Write_Str
(" library graph vertex (LGV_Id_");
781 Write_Int
(Int
(Vertex
));
782 Write_Str
(") lacks Corresponding_Item");
787 if not Present
(Unit
(G
, Vertex
)) then
788 Write_Error
(Msg
, Has_Invalid_Data
);
790 Write_Str
(" library graph vertex (LGV_Id_");
791 Write_Int
(Int
(Vertex
));
792 Write_Str
(") lacks Unit");
796 end Validate_Library_Graph_Vertex
;
798 -------------------------------------
799 -- Validate_Library_Graph_Vertices --
800 -------------------------------------
802 procedure Validate_Library_Graph_Vertices
(G
: Library_Graph
) is
803 Iter
: Library_Graphs
.All_Vertex_Iterator
;
804 Vertex
: Library_Graph_Vertex_Id
;
807 pragma Assert
(Present
(G
));
809 Iter
:= Iterate_All_Vertices
(G
);
810 while Has_Next
(Iter
) loop
813 Validate_Library_Graph_Vertex
(G
, Vertex
);
815 end Validate_Library_Graph_Vertices
;
816 end Library_Graph_Validators
;
822 procedure Write_Error
827 Write_Str
("ERROR: ");
834 end Bindo
.Validators
;