1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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;
30 with Namet; use Namet;
33 with Output; use Output;
34 with Targparm; use Targparm;
36 with System.Case_Util; use System.Case_Util;
40 -- The following data structures are used to represent the graph that is
41 -- used to determine the elaboration order (using a topological sort).
43 -- The following structures are used to record successors. If A is a
44 -- successor of B in this table, it means that A must be elaborated
45 -- before B is elaborated.
47 type Successor_Id is new Nat;
48 -- Identification of single successor entry
50 No_Successor : constant Successor_Id := 0;
51 -- Used to indicate end of list of successors
53 type Elab_All_Id is new Nat;
54 -- Identification of Elab_All entry link
56 No_Elab_All_Link : constant Elab_All_Id := 0;
57 -- Used to indicate end of list
59 -- Succ_Reason indicates the reason for a particular elaboration link
63 -- After directly with's Before, so the spec of Before must be
64 -- elaborated before After is elaborated.
67 -- After directly mentions Before in a pragma Elaborate, so the
68 -- body of Before must be elaborate before After is elaborated.
71 -- After either mentions Before directly in a pragma Elaborate_All,
72 -- or mentions a third unit, X, which itself requires that Before be
73 -- elaborated before unit X is elaborated. The Elab_All_Link list
74 -- traces the dependencies in the latter case.
77 -- This is just like Elab_All, except that the elaborate all was not
78 -- explicitly present in the source, but rather was created by the
79 -- front end, which decided that it was "desirable".
82 -- This is just like Elab, except that the elaborate was not
83 -- explicitly present in the source, but rather was created by the
84 -- front end, which decided that it was "desirable".
87 -- After is a body, and Before is the corresponding spec
89 -- Successor_Link contains the information for one link
91 type Successor_Link is record
99 -- Next successor on this list
101 Reason : Succ_Reason;
102 -- Reason for this link
105 -- Set True if this link is needed for the special Elaborate_Body
106 -- processing described below.
108 Reason_Unit : Unit_Id;
109 -- For Reason = Elab, or Elab_All or Elab_Desirable, records the unit
110 -- containing the pragma leading to the link.
112 Elab_All_Link : Elab_All_Id;
113 -- If Reason = Elab_All or Elab_Desirable, then this points to the
114 -- first elment in a list of Elab_All entries that record the with
115 -- chain leading resulting in this particular dependency.
119 -- Note on handling of Elaborate_Body. Basically, if we have a pragma
120 -- Elaborate_Body in a unit, it means that the spec and body have to
121 -- be handled as a single entity from the point of view of determining
122 -- an elaboration order. What we do is to essentially remove the body
123 -- from consideration completely, and transfer all its links (other
124 -- than the spec link) to the spec. Then when then the spec gets chosen,
125 -- we choose the body right afterwards. We mark the links that get moved
126 -- from the body to the spec by setting their Elab_Body flag True, so
127 -- that we can understand what is going on!
129 Succ_First : constant := 1;
131 package Succ is new Table.Table (
132 Table_Component_Type => Successor_Link,
133 Table_Index_Type => Successor_Id,
134 Table_Low_Bound => Succ_First,
135 Table_Initial => 500,
136 Table_Increment => 200,
137 Table_Name => "Succ");
139 -- For the case of Elaborate_All, the following table is used to record
140 -- chains of with relationships that lead to the Elab_All link. These
141 -- are used solely for diagnostic purposes
143 type Elab_All_Entry is record
144 Needed_By : Unit_Name_Type;
145 -- Name of unit from which referencing unit was with'ed or otherwise
146 -- needed as a result of Elaborate_All or Elaborate_Desirable.
148 Next_Elab : Elab_All_Id;
149 -- Link to next entry on chain (No_Elab_All_Link marks end of list)
152 package Elab_All_Entries is new Table.Table (
153 Table_Component_Type => Elab_All_Entry,
154 Table_Index_Type => Elab_All_Id,
155 Table_Low_Bound => 1,
156 Table_Initial => 2000,
157 Table_Increment => 200,
158 Table_Name => "Elab_All_Entries");
160 -- A Unit_Node record is built for each active unit
162 type Unit_Node_Record is record
164 Successors : Successor_Id;
165 -- Pointer to list of links for successor nodes
168 -- Number of predecessors for this unit. Normally non-negative, but
169 -- can go negative in the case of units chosen by the diagnose error
170 -- procedure (when cycles are being removed from the graph).
173 -- Forward pointer for list of units with no predecessors
176 -- Position in elaboration order (zero = not placed yet)
179 -- Used in computing transitive closure for elaborate all and
180 -- also in locating cycles and paths in the diagnose routines.
182 Elab_Position : Natural;
183 -- Initialized to zero. Set non-zero when a unit is chosen and
184 -- placed in the elaboration order. The value represents the
185 -- ordinal position in the elaboration order.
189 package UNR is new Table.Table (
190 Table_Component_Type => Unit_Node_Record,
191 Table_Index_Type => Unit_Id,
192 Table_Low_Bound => First_Unit_Entry,
193 Table_Initial => 500,
194 Table_Increment => 200,
195 Table_Name => "UNR");
198 -- Head of list of items with no predecessors
201 -- Number of entries not yet dealt with
204 -- Current unit, set by Gather_Dependencies, and picked up in Build_Link
205 -- to set the Reason_Unit field of the created dependency link.
207 Num_Chosen : Natural := 0;
208 -- Number of units chosen in the elaboration order so far
210 -----------------------
211 -- Local Subprograms --
212 -----------------------
214 function Better_Choice (U1, U2 : Unit_Id) return Boolean;
215 -- U1 and U2 are both permitted candidates for selection as the next unit
216 -- to be elaborated. This function determines whether U1 is a better choice
217 -- than U2, i.e. should be elaborated in preference to U2, based on a set
218 -- of heuristics that establish a friendly and predictable order (see body
219 -- for details). The result is True if U1 is a better choice than U2, and
220 -- False if it is a worse choice, or there is no preference between them.
226 Ea_Id : Elab_All_Id := No_Elab_All_Link);
227 -- Establish a successor link, Before must be elaborated before After, and
228 -- the reason for the link is R. Ea_Id is the contents to be placed in the
229 -- Elab_All_Link of the entry.
231 procedure Choose (Chosen : Unit_Id);
232 -- Chosen is the next entry chosen in the elaboration order. This procedure
233 -- updates all data structures appropriately.
235 function Corresponding_Body (U : Unit_Id) return Unit_Id;
236 pragma Inline (Corresponding_Body);
237 -- Given a unit which is a spec for which there is a separate body, return
238 -- the unit id of the body. It is an error to call this routine with a unit
239 -- that is not a spec, or which does not have a separate body.
241 function Corresponding_Spec (U : Unit_Id) return Unit_Id;
242 pragma Inline (Corresponding_Spec);
243 -- Given a unit which is a body for which there is a separate spec, return
244 -- the unit id of the spec. It is an error to call this routine with a unit
245 -- that is not a body, or which does not have a separate spec.
247 procedure Diagnose_Elaboration_Problem;
248 -- Called when no elaboration order can be found. Outputs an appropriate
249 -- diagnosis of the problem, and then abandons the bind.
251 procedure Elab_All_Links
254 Reason : Succ_Reason;
256 -- Used to compute the transitive closure of elaboration links for an
257 -- Elaborate_All pragma (Reason = Elab_All) or for an indication of
258 -- Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has
259 -- a pragma Elaborate_All or the front end has determined that a reference
260 -- probably requires Elaborate_All is required, and unit Before must be
261 -- previously elaborated. First a link is built making sure that unit
262 -- Before is elaborated before After, then a recursive call ensures that
263 -- we also build links for any units needed by Before (i.e. these units
264 -- must/should also be elaborated before After). Link is used to build
265 -- a chain of Elab_All_Entries to explain the reason for a link. The
266 -- value passed is the chain so far.
268 procedure Elab_Error_Msg (S : Successor_Id);
269 -- Given a successor link, outputs an error message of the form
270 -- "$ must be elaborated before $ ..." where ... is the reason.
272 procedure Gather_Dependencies;
273 -- Compute dependencies, building the Succ and UNR tables
275 function Is_Body_Unit (U : Unit_Id) return Boolean;
276 pragma Inline (Is_Body_Unit);
277 -- Determines if given unit is a body
279 function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean;
280 -- Returns True if corresponding unit is Pure or Preelaborate. Includes
281 -- dealing with testing flags on spec if it is given a body.
283 function Is_Waiting_Body (U : Unit_Id) return Boolean;
284 pragma Inline (Is_Waiting_Body);
285 -- Determines if U is a waiting body, defined as a body which has
286 -- not been elaborated, but whose spec has been elaborated.
288 function Make_Elab_Entry
289 (Unam : Unit_Name_Type;
290 Link : Elab_All_Id) return Elab_All_Id;
291 -- Make an Elab_All_Entries table entry with the given Unam and Link
293 function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean;
294 -- This is like Better_Choice, and has the same interface, but returns
295 -- true if U1 is a worse choice than U2 in the sense of the -p (pessimistic
296 -- elaboration order) switch. We still have to obey Ada rules, so it is
297 -- not quite the direct inverse of Better_Choice.
299 function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id;
300 -- This function uses the Info field set in the names table to obtain
301 -- the unit Id of a unit, given its name id value.
303 procedure Write_Dependencies;
304 -- Write out dependencies (called only if appropriate option is set)
306 procedure Write_Elab_All_Chain (S : Successor_Id);
307 -- If the reason for the link S is Elaborate_All or Elaborate_Desirable,
308 -- then this routine will output the "needed by" explanation chain.
314 function Better_Choice (U1, U2 : Unit_Id) return Boolean is
315 UT1 : Unit_Record renames Units.Table (U1);
316 UT2 : Unit_Record renames Units.Table (U2);
320 Write_Str ("Better_Choice (");
321 Write_Unit_Name (UT1.Uname);
323 Write_Unit_Name (UT2.Uname);
327 -- Note: the checks here are applied in sequence, and the ordering is
328 -- significant (i.e. the more important criteria are applied first).
330 -- Prefer a waiting body to one that is not a waiting body
332 if Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
334 Write_Line (" True: u1 is waiting body, u2 is not");
339 elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
341 Write_Line (" False: u2 is waiting body, u1 is not");
346 -- Prefer a predefined unit to a non-predefined unit
348 elsif UT1.Predefined and then not UT2.Predefined then
350 Write_Line (" True: u1 is predefined, u2 is not");
355 elsif UT2.Predefined and then not UT1.Predefined then
357 Write_Line (" False: u2 is predefined, u1 is not");
362 -- Prefer an internal unit to a non-internal unit
364 elsif UT1.Internal and then not UT2.Internal then
366 Write_Line (" True: u1 is internal, u2 is not");
370 elsif UT2.Internal and then not UT1.Internal then
372 Write_Line (" False: u2 is internal, u1 is not");
377 -- Prefer a pure or preelaborable unit to one that is not
379 elsif Is_Pure_Or_Preelab_Unit (U1)
381 Is_Pure_Or_Preelab_Unit (U2)
384 Write_Line (" True: u1 is pure/preelab, u2 is not");
389 elsif Is_Pure_Or_Preelab_Unit (U2)
391 Is_Pure_Or_Preelab_Unit (U1)
394 Write_Line (" False: u2 is pure/preelab, u1 is not");
399 -- Prefer a body to a spec
401 elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
403 Write_Line (" True: u1 is body, u2 is not");
408 elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
410 Write_Line (" False: u2 is body, u1 is not");
415 -- If both are waiting bodies, then prefer the one whose spec is
416 -- more recently elaborated. Consider the following:
422 -- The normal waiting body preference would have placed the body of
423 -- A before the spec of B if it could. Since it could not, there it
424 -- must be the case that A depends on B. It is therefore a good idea
425 -- to put the body of B first.
427 elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
429 Result : constant Boolean :=
430 UNR.Table (Corresponding_Spec (U1)).Elab_Position >
431 UNR.Table (Corresponding_Spec (U2)).Elab_Position;
435 Write_Line (" True: based on waiting body elab positions");
437 Write_Line (" False: based on waiting body elab positions");
445 -- Remaining choice rules are disabled by Debug flag -do
447 if not Debug_Flag_O then
449 -- The following deal with the case of specs which have been marked
450 -- as Elaborate_Body_Desirable. We generally want to delay these
451 -- specs as long as possible, so that the bodies have a better chance
452 -- of being elaborated closer to the specs.
454 -- If we have two units, one of which is a spec for which this flag
455 -- is set, and the other is not, we prefer to delay the spec for
456 -- which the flag is set.
458 if not UT1.Elaborate_Body_Desirable
459 and then UT2.Elaborate_Body_Desirable
462 Write_Line (" True: u1 is elab body desirable, u2 is not");
467 elsif not UT2.Elaborate_Body_Desirable
468 and then UT1.Elaborate_Body_Desirable
471 Write_Line (" False: u1 is elab body desirable, u2 is not");
476 -- If we have two specs that are both marked as Elaborate_Body
477 -- desirable, we prefer the one whose body is nearer to being able
478 -- to be elaborated, based on the Num_Pred count. This helps to
479 -- ensure bodies are as close to specs as possible.
481 elsif UT1.Elaborate_Body_Desirable
482 and then UT2.Elaborate_Body_Desirable
485 Result : constant Boolean :=
486 UNR.Table (Corresponding_Body (U1)).Num_Pred <
487 UNR.Table (Corresponding_Body (U2)).Num_Pred;
491 Write_Line (" True based on Num_Pred compare");
493 Write_Line (" False based on Num_Pred compare");
502 -- If we fall through, it means that no preference rule applies, so we
503 -- use alphabetical order to at least give a deterministic result.
506 Write_Line (" choose on alpha order");
509 return Uname_Less (UT1.Uname, UT2.Uname);
520 Ea_Id : Elab_All_Id := No_Elab_All_Link)
526 Succ.Table (Succ.Last).Before := Before;
527 Succ.Table (Succ.Last).Next := UNR.Table (Before).Successors;
528 UNR.Table (Before).Successors := Succ.Last;
529 Succ.Table (Succ.Last).Reason := R;
530 Succ.Table (Succ.Last).Reason_Unit := Cur_Unit;
531 Succ.Table (Succ.Last).Elab_All_Link := Ea_Id;
533 -- Deal with special Elab_Body case. If the After of this link is
534 -- a body whose spec has Elaborate_All set, and this is not the link
535 -- directly from the body to the spec, then we make the After of the
536 -- link reference its spec instead, marking the link appropriately.
538 if Units.Table (After).Utype = Is_Body then
539 Cspec := Corresponding_Spec (After);
541 if Units.Table (Cspec).Elaborate_Body
542 and then Cspec /= Before
544 Succ.Table (Succ.Last).After := Cspec;
545 Succ.Table (Succ.Last).Elab_Body := True;
546 UNR.Table (Cspec).Num_Pred := UNR.Table (Cspec).Num_Pred + 1;
551 -- Fall through on normal case
553 Succ.Table (Succ.Last).After := After;
554 Succ.Table (Succ.Last).Elab_Body := False;
555 UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1;
562 procedure Choose (Chosen : Unit_Id) is
568 Write_Str ("Choosing Unit ");
569 Write_Unit_Name (Units.Table (Chosen).Uname);
573 -- Add to elaboration order. Note that units having no elaboration
574 -- code are not treated specially yet. The special casing of this
575 -- is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile
576 -- we need them here, because the object file list is also driven
577 -- by the contents of the Elab_Order table.
579 Elab_Order.Increment_Last;
580 Elab_Order.Table (Elab_Order.Last) := Chosen;
582 -- Remove from No_Pred list. This is a little inefficient and may
583 -- be we should doubly link the list, but it will do for now!
585 if No_Pred = Chosen then
586 No_Pred := UNR.Table (Chosen).Nextnp;
589 -- Note that we just ignore the situation where it does not
590 -- appear in the No_Pred list, this happens in calls from the
591 -- Diagnose_Elaboration_Problem routine, where cycles are being
592 -- removed arbitrarily from the graph.
595 while U /= No_Unit_Id loop
596 if UNR.Table (U).Nextnp = Chosen then
597 UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp;
601 U := UNR.Table (U).Nextnp;
605 -- For all successors, decrement the number of predecessors, and
606 -- if it becomes zero, then add to no predecessor list.
608 S := UNR.Table (Chosen).Successors;
609 while S /= No_Successor loop
610 U := Succ.Table (S).After;
611 UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1;
614 Write_Str (" decrementing Num_Pred for unit ");
615 Write_Unit_Name (Units.Table (U).Uname);
616 Write_Str (" new value = ");
617 Write_Int (UNR.Table (U).Num_Pred);
621 if UNR.Table (U).Num_Pred = 0 then
622 UNR.Table (U).Nextnp := No_Pred;
626 S := Succ.Table (S).Next;
629 -- All done, adjust number of units left count and set elaboration pos
631 Num_Left := Num_Left - 1;
632 Num_Chosen := Num_Chosen + 1;
633 UNR.Table (Chosen).Elab_Position := Num_Chosen;
634 Units.Table (Chosen).Elab_Position := Num_Chosen;
636 -- If we just chose a spec with Elaborate_Body set, then we
637 -- must immediately elaborate the body, before any other units.
639 if Units.Table (Chosen).Elaborate_Body then
641 -- If the unit is a spec only, then there is no body. This is a bit
642 -- odd given that Elaborate_Body is here, but it is valid in an
643 -- RCI unit, where we only have the interface in the stub bind.
645 if Units.Table (Chosen).Utype = Is_Spec_Only
646 and then Units.Table (Chosen).RCI
650 Choose (Corresponding_Body (Chosen));
655 ------------------------
656 -- Corresponding_Body --
657 ------------------------
659 -- Currently if the body and spec are separate, then they appear as
660 -- two separate units in the same ALI file, with the body appearing
661 -- first and the spec appearing second.
663 function Corresponding_Body (U : Unit_Id) return Unit_Id is
665 pragma Assert (Units.Table (U).Utype = Is_Spec);
667 end Corresponding_Body;
669 ------------------------
670 -- Corresponding_Spec --
671 ------------------------
673 -- Currently if the body and spec are separate, then they appear as
674 -- two separate units in the same ALI file, with the body appearing
675 -- first and the spec appearing second.
677 function Corresponding_Spec (U : Unit_Id) return Unit_Id is
679 pragma Assert (Units.Table (U).Utype = Is_Body);
681 end Corresponding_Spec;
683 ----------------------------------
684 -- Diagnose_Elaboration_Problem --
685 ----------------------------------
687 procedure Diagnose_Elaboration_Problem is
689 function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean;
690 -- Recursive routine used to find a path from node Ufrom to node Uto.
691 -- If a path exists, returns True and outputs an appropriate set of
692 -- error messages giving the path. Also calls Choose for each of the
693 -- nodes so that they get removed from the remaining set. There are
694 -- two cases of calls, either Ufrom = Uto for an attempt to find a
695 -- cycle, or Ufrom is a spec and Uto the corresponding body for the
696 -- case of an unsatisfiable Elaborate_Body pragma. ML is the minimum
697 -- acceptable length for a path.
703 function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is
705 function Find_Link (U : Unit_Id; PL : Nat) return Boolean;
706 -- This is the inner recursive routine, it determines if a path
707 -- exists from U to Uto, and if so returns True and outputs the
708 -- appropriate set of error messages. PL is the path length
714 function Find_Link (U : Unit_Id; PL : Nat) return Boolean is
718 -- Recursion ends if we are at terminating node and the path
719 -- is sufficiently long, generate error message and return True.
721 if U = Uto and then PL >= ML then
725 -- All done if already visited, otherwise mark as visited
727 elsif UNR.Table (U).Visited then
730 -- Otherwise mark as visited and look at all successors
733 UNR.Table (U).Visited := True;
735 S := UNR.Table (U).Successors;
736 while S /= No_Successor loop
737 if Find_Link (Succ.Table (S).After, PL + 1) then
743 S := Succ.Table (S).Next;
746 -- Falling through means this does not lead to a path
752 -- Start of processing for Find_Path
755 -- Initialize all non-chosen nodes to not visisted yet
757 for U in Units.First .. Units.Last loop
758 UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0;
761 -- Now try to find the path
763 return Find_Link (Ufrom, 0);
766 -- Start of processing for Diagnose_Elaboration_Error
771 -- Output state of things if debug flag N set
780 Write_Str ("Diagnose_Elaboration_Problem called");
782 Write_Str ("List of remaining unchosen units and predecessors");
785 for U in Units.First .. Units.Last loop
786 if UNR.Table (U).Elab_Position = 0 then
787 NP := UNR.Table (U).Num_Pred;
789 Write_Str (" Unchosen unit: #");
792 Write_Unit_Name (Units.Table (U).Uname);
793 Write_Str (" (Num_Pred = ");
799 if Units.Table (U).Elaborate_Body then
801 (" (not chosen because of Elaborate_Body)");
804 Write_Str (" ****************** why not chosen?");
809 -- Search links list to find unchosen predecessors
811 for S in Succ.First .. Succ.Last loop
813 SL : Successor_Link renames Succ.Table (S);
817 and then UNR.Table (SL.Before).Elab_Position = 0
819 Write_Str (" unchosen predecessor: #");
820 Write_Int (Int (SL.Before));
822 Write_Unit_Name (Units.Table (SL.Before).Uname);
830 Write_Str (" **************** Num_Pred value wrong!");
838 -- Output the header for the error, and manually increment the
839 -- error count. We are using Error_Msg_Output rather than Error_Msg
840 -- here for two reasons:
842 -- This is really only one error, not one for each line
843 -- We want this output on standard output since it is voluminous
845 -- But we do need to deal with the error count manually in this case
847 Errors_Detected := Errors_Detected + 1;
848 Error_Msg_Output ("elaboration circularity detected", Info => False);
850 -- Try to find cycles starting with any of the remaining nodes that have
851 -- not yet been chosen. There must be at least one (there is some reason
852 -- we are being called!)
854 for U in Units.First .. Units.Last loop
855 if UNR.Table (U).Elab_Position = 0 then
856 if Find_Path (U, U, 1) then
857 raise Unrecoverable_Error;
862 -- We should never get here, since we were called for some reason,
863 -- and we should have found and eliminated at least one bad path.
866 end Diagnose_Elaboration_Problem;
872 procedure Elab_All_Links
875 Reason : Succ_Reason;
879 if UNR.Table (Before).Visited then
883 -- Build the direct link for Before
885 UNR.Table (Before).Visited := True;
886 Build_Link (Before, After, Reason, Link);
888 -- Process all units with'ed by Before recursively
891 Units.Table (Before).First_With .. Units.Table (Before).Last_With
893 -- Skip if this with is an interface to a stand-alone library.
894 -- Skip also if no ALI file for this WITH, happens for language
895 -- defined generics while bootstrapping the compiler (see body of
896 -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited
897 -- with clause, which does not impose an elaboration link.
899 if not Withs.Table (W).SAL_Interface
900 and then Withs.Table (W).Afile /= No_File
901 and then not Withs.Table (W).Limited_With
904 Info : constant Int :=
905 Get_Name_Table_Info (Withs.Table (W).Uname);
908 -- If the unit is unknown, for some unknown reason, fail
909 -- graciously explaining that the unit is unknown. Without
910 -- this check, gnatbind will crash in Unit_Id_Of.
912 if Info = 0 or else Unit_Id (Info) = No_Unit_Id then
915 Get_Name_String (Withs.Table (W).Uname);
916 Last_Withed : Natural := Withed'Last;
918 Get_Name_String (Units.Table (Before).Uname);
919 Last_Withing : Natural := Withing'Last;
920 Spec_Body : String := " (Spec)";
926 if Last_Withed > 2 and then
927 Withed (Last_Withed - 1) = '%'
929 Last_Withed := Last_Withed - 2;
932 if Last_Withing > 2 and then
933 Withing (Last_Withing - 1) = '%'
935 Last_Withing := Last_Withing - 2;
938 if Units.Table (Before).Utype = Is_Body or else
939 Units.Table (Before).Utype = Is_Body_Only
941 Spec_Body := " (Body)";
945 ("could not find unit "
946 & Withed (Withed'First .. Last_Withed) & " needed by "
947 & Withing (Withing'First .. Last_Withing) & Spec_Body);
952 (Unit_Id_Of (Withs.Table (W).Uname),
955 Make_Elab_Entry (Withs.Table (W).Uname, Link));
960 -- Process corresponding body, if there is one
962 if Units.Table (Before).Utype = Is_Spec then
964 (Corresponding_Body (Before),
967 (Units.Table (Corresponding_Body (Before)).Uname, Link));
975 procedure Elab_Error_Msg (S : Successor_Id) is
976 SL : Successor_Link renames Succ.Table (S);
979 -- Nothing to do if internal unit involved and no -da flag
983 (Is_Internal_File_Name (Units.Table (SL.Before).Sfile)
985 Is_Internal_File_Name (Units.Table (SL.After).Sfile))
990 -- Here we want to generate output
992 Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
995 Error_Msg_Unit_2 := Units.Table (Corresponding_Body (SL.After)).Uname;
997 Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
1000 Error_Msg_Output (" $ must be elaborated before $", Info => True);
1002 Error_Msg_Unit_1 := Units.Table (SL.Reason_Unit).Uname;
1007 (" reason: with clause",
1012 (" reason: pragma Elaborate in unit $",
1017 (" reason: pragma Elaborate_All in unit $",
1020 when Elab_All_Desirable =>
1022 (" reason: implicit Elaborate_All in unit $",
1026 (" recompile $ with -gnatwl for full details",
1029 when Elab_Desirable =>
1031 (" reason: implicit Elaborate in unit $",
1035 (" recompile $ with -gnatwl for full details",
1040 (" reason: spec always elaborated before body",
1044 Write_Elab_All_Chain (S);
1046 if SL.Elab_Body then
1047 Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
1048 Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
1050 (" $ must therefore be elaborated before $",
1053 Error_Msg_Unit_1 := Units.Table (SL.After).Uname;
1055 (" (because $ has a pragma Elaborate_Body)",
1059 if not Zero_Formatting then
1064 ---------------------
1065 -- Find_Elab_Order --
1066 ---------------------
1068 procedure Find_Elab_Order is
1070 Best_So_Far : Unit_Id;
1074 Num_Left := Int (Units.Last - Units.First + 1);
1076 -- Initialize unit table for elaboration control
1078 for U in Units.First .. Units.Last loop
1080 UNR.Table (UNR.Last).Successors := No_Successor;
1081 UNR.Table (UNR.Last).Num_Pred := 0;
1082 UNR.Table (UNR.Last).Nextnp := No_Unit_Id;
1083 UNR.Table (UNR.Last).Elab_Order := 0;
1084 UNR.Table (UNR.Last).Elab_Position := 0;
1087 -- Output warning if -p used with no -gnatE units
1089 if Pessimistic_Elab_Order
1090 and not Dynamic_Elaboration_Checks_Specified
1092 if OpenVMS_On_Target then
1093 Error_Msg ("?use of /PESSIMISTIC_ELABORATION questionable");
1095 Error_Msg ("?use of -p switch questionable");
1098 Error_Msg ("?since all units compiled with static elaboration model");
1101 -- Gather dependencies and output them if option set
1103 Gather_Dependencies;
1105 -- Output elaboration dependencies if option is set
1107 if Elab_Dependency_Output or Debug_Flag_E then
1111 -- Initialize the no predecessor list
1113 No_Pred := No_Unit_Id;
1115 for U in UNR.First .. UNR.Last loop
1116 if UNR.Table (U).Num_Pred = 0 then
1117 UNR.Table (U).Nextnp := No_Pred;
1122 -- OK, now we determine the elaboration order proper. All we do is to
1123 -- select the best choice from the no predecessor list until all the
1124 -- nodes have been chosen.
1128 -- If there are no nodes with predecessors, then either we are
1129 -- done, as indicated by Num_Left being set to zero, or we have
1130 -- a circularity. In the latter case, diagnose the circularity,
1131 -- removing it from the graph and continue
1133 Get_No_Pred : while No_Pred = No_Unit_Id loop
1134 exit Outer when Num_Left < 1;
1135 Diagnose_Elaboration_Problem;
1136 end loop Get_No_Pred;
1139 Best_So_Far := No_Unit_Id;
1141 -- Loop to choose best entry in No_Pred list
1143 No_Pred_Search : loop
1144 if Debug_Flag_N then
1145 Write_Str (" considering choice of ");
1146 Write_Unit_Name (Units.Table (U).Uname);
1149 if Units.Table (U).Elaborate_Body then
1151 (" Elaborate_Body = True, Num_Pred for body = ");
1153 (UNR.Table (Corresponding_Body (U)).Num_Pred);
1156 (" Elaborate_Body = False");
1162 -- This is a candididate to be considered for choice
1164 if Best_So_Far = No_Unit_Id
1165 or else ((not Pessimistic_Elab_Order)
1166 and then Better_Choice (U, Best_So_Far))
1167 or else (Pessimistic_Elab_Order
1168 and then Pessimistic_Better_Choice (U, Best_So_Far))
1170 if Debug_Flag_N then
1171 Write_Str (" tentatively chosen (best so far)");
1178 U := UNR.Table (U).Nextnp;
1179 exit No_Pred_Search when U = No_Unit_Id;
1180 end loop No_Pred_Search;
1182 -- If no candididate chosen, it means that no unit has No_Pred = 0,
1183 -- but there are units left, hence we have a circular dependency,
1184 -- which we will get Diagnose_Elaboration_Problem to diagnose it.
1186 if Best_So_Far = No_Unit_Id then
1187 Diagnose_Elaboration_Problem;
1189 -- Otherwise choose the best candidate found
1192 Choose (Best_So_Far);
1195 end Find_Elab_Order;
1197 -------------------------
1198 -- Gather_Dependencies --
1199 -------------------------
1201 procedure Gather_Dependencies is
1202 Withed_Unit : Unit_Id;
1205 -- Loop through all units
1207 for U in Units.First .. Units.Last loop
1210 -- If this is not an interface to a stand-alone library and
1211 -- there is a body and a spec, then spec must be elaborated first
1212 -- Note that the corresponding spec immediately follows the body
1214 if not Units.Table (U).SAL_Interface
1215 and then Units.Table (U).Utype = Is_Body
1217 Build_Link (Corresponding_Spec (U), U, Spec_First);
1220 -- If this unit is not an interface to a stand-alone library,
1221 -- process WITH references for this unit ignoring generic units and
1222 -- interfaces to stand-alone libraries.
1224 if not Units.Table (U).SAL_Interface then
1226 W in Units.Table (U).First_With .. Units.Table (U).Last_With
1228 if Withs.Table (W).Sfile /= No_File
1229 and then (not Withs.Table (W).SAL_Interface)
1231 -- Check for special case of withing a unit that does not
1232 -- exist any more. If the unit was completely missing we
1233 -- would already have detected this, but a nasty case arises
1234 -- when we have a subprogram body with no spec, and some
1235 -- obsolete unit with's a previous (now disappeared) spec.
1237 if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then
1238 Error_Msg_File_1 := Units.Table (U).Sfile;
1239 Error_Msg_Unit_1 := Withs.Table (W).Uname;
1240 Error_Msg ("{ depends on $ which no longer exists");
1244 Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname);
1246 -- Pragma Elaborate_All case, for this we use the recursive
1247 -- Elab_All_Links procedure to establish the links.
1249 if Withs.Table (W).Elaborate_All then
1251 -- Reset flags used to stop multiple visits to a given
1254 for Uref in UNR.First .. UNR.Last loop
1255 UNR.Table (Uref).Visited := False;
1258 -- Now establish all the links we need
1261 (Withed_Unit, U, Elab_All,
1263 (Withs.Table (W).Uname, No_Elab_All_Link));
1265 -- Elaborate_All_Desirable case, for this we establish the
1266 -- same links as above, but with a different reason.
1268 elsif Withs.Table (W).Elab_All_Desirable then
1270 -- Reset flags used to stop multiple visits to a given
1273 for Uref in UNR.First .. UNR.Last loop
1274 UNR.Table (Uref).Visited := False;
1277 -- Now establish all the links we need
1280 (Withed_Unit, U, Elab_All_Desirable,
1282 (Withs.Table (W).Uname, No_Elab_All_Link));
1284 -- Pragma Elaborate case. We must build a link for the
1285 -- withed unit itself, and also the corresponding body if
1288 -- However, skip this processing if there is no ALI file for
1289 -- the WITH entry, because this means it is a generic (even
1290 -- when we fix the generics so that an ALI file is present,
1291 -- we probably still will have no ALI file for unchecked and
1292 -- other special cases).
1294 elsif Withs.Table (W).Elaborate
1295 and then Withs.Table (W).Afile /= No_File
1297 Build_Link (Withed_Unit, U, Withed);
1299 if Units.Table (Withed_Unit).Utype = Is_Spec then
1301 (Corresponding_Body (Withed_Unit), U, Elab);
1304 -- Elaborate_Desirable case, for this we establish
1305 -- the same links as above, but with a different reason.
1307 elsif Withs.Table (W).Elab_Desirable then
1308 Build_Link (Withed_Unit, U, Withed);
1310 if Units.Table (Withed_Unit).Utype = Is_Spec then
1312 (Corresponding_Body (Withed_Unit),
1316 -- A limited_with does not establish an elaboration
1317 -- dependence (that's the whole point!).
1319 elsif Withs.Table (W).Limited_With then
1322 -- Case of normal WITH with no elaboration pragmas, just
1323 -- build the single link to the directly referenced unit
1326 Build_Link (Withed_Unit, U, Withed);
1335 end Gather_Dependencies;
1341 function Is_Body_Unit (U : Unit_Id) return Boolean is
1343 return Units.Table (U).Utype = Is_Body
1344 or else Units.Table (U).Utype = Is_Body_Only;
1347 -----------------------------
1348 -- Is_Pure_Or_Preelab_Unit --
1349 -----------------------------
1351 function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean is
1353 -- If we have a body with separate spec, test flags on the spec
1355 if Units.Table (U).Utype = Is_Body then
1356 return Units.Table (U + 1).Preelab
1358 Units.Table (U + 1).Pure;
1360 -- Otherwise we have a spec or body acting as spec, test flags on unit
1363 return Units.Table (U).Preelab
1365 Units.Table (U).Pure;
1367 end Is_Pure_Or_Preelab_Unit;
1369 ---------------------
1370 -- Is_Waiting_Body --
1371 ---------------------
1373 function Is_Waiting_Body (U : Unit_Id) return Boolean is
1375 return Units.Table (U).Utype = Is_Body
1376 and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
1377 end Is_Waiting_Body;
1379 ---------------------
1380 -- Make_Elab_Entry --
1381 ---------------------
1383 function Make_Elab_Entry
1384 (Unam : Unit_Name_Type;
1385 Link : Elab_All_Id) return Elab_All_Id
1388 Elab_All_Entries.Increment_Last;
1389 Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam;
1390 Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link;
1391 return Elab_All_Entries.Last;
1392 end Make_Elab_Entry;
1394 -------------------------------
1395 -- Pessimistic_Better_Choice --
1396 -------------------------------
1398 function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean is
1399 UT1 : Unit_Record renames Units.Table (U1);
1400 UT2 : Unit_Record renames Units.Table (U2);
1403 if Debug_Flag_B then
1404 Write_Str ("Pessimistic_Better_Choice (");
1405 Write_Unit_Name (UT1.Uname);
1407 Write_Unit_Name (UT2.Uname);
1411 -- Note: the checks here are applied in sequence, and the ordering is
1412 -- significant (i.e. the more important criteria are applied first).
1414 -- If either unit is predefined or internal, then we use the normal
1415 -- Better_Choice rule, since we don't want to disturb the elaboration
1416 -- rules of the language with -p, same treatment for Pure/Preelab.
1418 -- Prefer a predefined unit to a non-predefined unit
1420 if UT1.Predefined and then not UT2.Predefined then
1421 if Debug_Flag_B then
1422 Write_Line (" True: u1 is predefined, u2 is not");
1427 elsif UT2.Predefined and then not UT1.Predefined then
1428 if Debug_Flag_B then
1429 Write_Line (" False: u2 is predefined, u1 is not");
1434 -- Prefer an internal unit to a non-internal unit
1436 elsif UT1.Internal and then not UT2.Internal then
1437 if Debug_Flag_B then
1438 Write_Line (" True: u1 is internal, u2 is not");
1443 elsif UT2.Internal and then not UT1.Internal then
1444 if Debug_Flag_B then
1445 Write_Line (" False: u2 is internal, u1 is not");
1450 -- Prefer a pure or preelaborable unit to one that is not
1452 elsif Is_Pure_Or_Preelab_Unit (U1)
1454 Is_Pure_Or_Preelab_Unit (U2)
1456 if Debug_Flag_B then
1457 Write_Line (" True: u1 is pure/preelab, u2 is not");
1462 elsif Is_Pure_Or_Preelab_Unit (U2)
1464 Is_Pure_Or_Preelab_Unit (U1)
1466 if Debug_Flag_B then
1467 Write_Line (" False: u2 is pure/preelab, u1 is not");
1472 -- Prefer anything else to a waiting body. We want to make bodies wait
1473 -- as long as possible, till we are forced to choose them!
1475 elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
1476 if Debug_Flag_B then
1477 Write_Line (" False: u1 is waiting body, u2 is not");
1482 elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
1483 if Debug_Flag_B then
1484 Write_Line (" True: u2 is waiting body, u1 is not");
1489 -- Prefer a spec to a body (!)
1491 elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
1492 if Debug_Flag_B then
1493 Write_Line (" False: u1 is body, u2 is not");
1498 elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
1499 if Debug_Flag_B then
1500 Write_Line (" True: u2 is body, u1 is not");
1505 -- If both are waiting bodies, then prefer the one whose spec is
1506 -- less recently elaborated. Consider the following:
1512 -- The normal waiting body preference would have placed the body of
1513 -- A before the spec of B if it could. Since it could not, there it
1514 -- must be the case that A depends on B. It is therefore a good idea
1515 -- to put the body of B last so that if there is an elaboration order
1516 -- problem, we will find it (that's what pessimistic order is about)
1518 elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
1520 Result : constant Boolean :=
1521 UNR.Table (Corresponding_Spec (U1)).Elab_Position <
1522 UNR.Table (Corresponding_Spec (U2)).Elab_Position;
1524 if Debug_Flag_B then
1526 Write_Line (" True: based on waiting body elab positions");
1528 Write_Line (" False: based on waiting body elab positions");
1536 -- Remaining choice rules are disabled by Debug flag -do
1538 if not Debug_Flag_O then
1540 -- The following deal with the case of specs which have been marked
1541 -- as Elaborate_Body_Desirable. In the normal case, we generally want
1542 -- to delay the elaboration of these specs as long as possible, so
1543 -- that bodies have better chance of being elaborated closer to the
1544 -- specs. Pessimistic_Better_Choice as usual wants to do the opposite
1545 -- and elaborate such specs as early as possible.
1547 -- If we have two units, one of which is a spec for which this flag
1548 -- is set, and the other is not, we normally prefer to delay the spec
1549 -- for which the flag is set, so again Pessimistic_Better_Choice does
1552 if not UT1.Elaborate_Body_Desirable
1553 and then UT2.Elaborate_Body_Desirable
1555 if Debug_Flag_B then
1556 Write_Line (" False: u1 is elab body desirable, u2 is not");
1561 elsif not UT2.Elaborate_Body_Desirable
1562 and then UT1.Elaborate_Body_Desirable
1564 if Debug_Flag_B then
1565 Write_Line (" True: u1 is elab body desirable, u2 is not");
1570 -- If we have two specs that are both marked as Elaborate_Body
1571 -- desirable, we normally prefer the one whose body is nearer to
1572 -- being able to be elaborated, based on the Num_Pred count. This
1573 -- helps to ensure bodies are as close to specs as possible. As
1574 -- usual, Pessimistic_Better_Choice does the opposite.
1576 elsif UT1.Elaborate_Body_Desirable
1577 and then UT2.Elaborate_Body_Desirable
1580 Result : constant Boolean :=
1581 UNR.Table (Corresponding_Body (U1)).Num_Pred >=
1582 UNR.Table (Corresponding_Body (U2)).Num_Pred;
1584 if Debug_Flag_B then
1586 Write_Line (" True based on Num_Pred compare");
1588 Write_Line (" False based on Num_Pred compare");
1597 -- If we fall through, it means that no preference rule applies, so we
1598 -- use alphabetical order to at least give a deterministic result. Since
1599 -- Pessimistic_Better_Choice is in the business of stirring up the
1600 -- order, we will use reverse alphabetical ordering.
1602 if Debug_Flag_B then
1603 Write_Line (" choose on reverse alpha order");
1606 return Uname_Less (UT2.Uname, UT1.Uname);
1607 end Pessimistic_Better_Choice;
1613 function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
1614 Info : constant Int := Get_Name_Table_Info (Uname);
1616 pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
1617 return Unit_Id (Info);
1620 ------------------------
1621 -- Write_Dependencies --
1622 ------------------------
1624 procedure Write_Dependencies is
1626 if not Zero_Formatting then
1628 Write_Str (" ELABORATION ORDER DEPENDENCIES");
1633 Info_Prefix_Suppress := True;
1635 for S in Succ_First .. Succ.Last loop
1639 Info_Prefix_Suppress := False;
1641 if not Zero_Formatting then
1644 end Write_Dependencies;
1646 --------------------------
1647 -- Write_Elab_All_Chain --
1648 --------------------------
1650 procedure Write_Elab_All_Chain (S : Successor_Id) is
1651 ST : constant Successor_Link := Succ.Table (S);
1652 After : constant Unit_Name_Type := Units.Table (ST.After).Uname;
1655 Nam : Unit_Name_Type;
1657 First_Name : Boolean := True;
1660 if ST.Reason in Elab_All .. Elab_All_Desirable then
1661 L := ST.Elab_All_Link;
1662 while L /= No_Elab_All_Link loop
1663 Nam := Elab_All_Entries.Table (L).Needed_By;
1664 Error_Msg_Unit_1 := Nam;
1665 Error_Msg_Output (" $", Info => True);
1667 Get_Name_String (Nam);
1669 if Name_Buffer (Name_Len) = 'b' then
1672 (" must be elaborated along with its spec:",
1677 (" which must be elaborated " &
1678 "along with its spec:",
1690 (" which is withed by:",
1695 First_Name := False;
1697 L := Elab_All_Entries.Table (L).Next_Elab;
1700 Error_Msg_Unit_1 := After;
1701 Error_Msg_Output (" $", Info => True);
1703 end Write_Elab_All_Chain;