1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- GNAT was originally developed by the GNAT team at New York University. --
24 -- Extensive contributions were provided by Ada Core Technologies Inc. --
26 ------------------------------------------------------------------------------
28 with Binderr; use Binderr;
29 with Butil; use Butil;
30 with Debug; use Debug;
31 with Fname; use Fname;
32 with Namet; use Namet;
34 with Output; use Output;
38 -- The following data structures are used to represent the graph that is
39 -- used to determine the elaboration order (using a topological sort).
41 -- The following structures are used to record successors. If A is a
42 -- successor of B in this table, it means that A must be elaborated
43 -- before B is elaborated.
45 type Successor_Id is new Nat;
46 -- Identification of single successor entry
48 No_Successor : constant Successor_Id := 0;
49 -- Used to indicate end of list of successors
51 type Elab_All_Id is new Nat;
52 -- Identification of Elab_All entry link
54 No_Elab_All_Link : constant Elab_All_Id := 0;
55 -- Used to indicate end of list
57 -- Succ_Reason indicates the reason for a particular elaboration link
61 -- After directly with's Before, so the spec of Before must be
62 -- elaborated before After is elaborated.
65 -- After directly mentions Before in a pragma Elaborate, so the
66 -- body of Before must be elaborate before After is elaborated.
69 -- After either mentions Before directly in a pragma Elaborate_All,
70 -- or mentions a third unit, X, which itself requires that Before be
71 -- elaborated before unit X is elaborated. The Elab_All_Link list
72 -- traces the dependencies in the latter case.
75 -- This is just like Elab_All, except that the elaborate all was not
76 -- explicitly present in the source, but rather was created by the
77 -- front end, which decided that it was "desirable".
80 -- After is a body, and Before is the corresponding spec
82 -- Successor_Link contains the information for one link
84 type Successor_Link is record
92 -- Next successor on this list
95 -- Reason for this link
98 -- Set True if this link is needed for the special Elaborate_Body
99 -- processing described below.
101 Reason_Unit : Unit_Id;
102 -- For Reason = Elab, or Elab_All or Elab_Desirable, records the unit
103 -- containing the pragma leading to the link.
105 Elab_All_Link : Elab_All_Id;
106 -- If Reason = Elab_All or Elab_Desirable, then this points to the
107 -- first elment in a list of Elab_All entries that record the with
108 -- chain leading resulting in this particular dependency.
112 -- Note on handling of Elaborate_Body. Basically, if we have a pragma
113 -- Elaborate_Body in a unit, it means that the spec and body have to
114 -- be handled as a single entity from the point of view of determining
115 -- an elaboration order. What we do is to essentially remove the body
116 -- from consideration completely, and transfer all its links (other
117 -- than the spec link) to the spec. Then when then the spec gets chosen,
118 -- we choose the body right afterwards. We mark the links that get moved
119 -- from the body to the spec by setting their Elab_Body flag True, so
120 -- that we can understand what is going on!
122 Succ_First : constant := 1;
124 package Succ is new Table.Table (
125 Table_Component_Type => Successor_Link,
126 Table_Index_Type => Successor_Id,
127 Table_Low_Bound => Succ_First,
128 Table_Initial => 500,
129 Table_Increment => 200,
130 Table_Name => "Succ");
132 -- For the case of Elaborate_All, the following table is used to record
133 -- chains of with relationships that lead to the Elab_All link. These
134 -- are used solely for diagnostic purposes
136 type Elab_All_Entry is record
137 Needed_By : Unit_Name_Type;
138 -- Name of unit from which referencing unit was with'ed or otherwise
139 -- needed as a result of Elaborate_All or Elaborate_Desirable.
141 Next_Elab : Elab_All_Id;
142 -- Link to next entry on chain (No_Elab_All_Link marks end of list)
145 package Elab_All_Entries is new Table.Table (
146 Table_Component_Type => Elab_All_Entry,
147 Table_Index_Type => Elab_All_Id,
148 Table_Low_Bound => 1,
149 Table_Initial => 2000,
150 Table_Increment => 200,
151 Table_Name => "Elab_All_Entries");
153 -- A Unit_Node record is built for each active unit
155 type Unit_Node_Record is record
157 Successors : Successor_Id;
158 -- Pointer to list of links for successor nodes
161 -- Number of predecessors for this unit. Normally non-negative, but
162 -- can go negative in the case of units chosen by the diagnose error
163 -- procedure (when cycles are being removed from the graph).
166 -- Forward pointer for list of units with no predecessors
169 -- Position in elaboration order (zero = not placed yet)
172 -- Used in computing transitive closure for elaborate all and
173 -- also in locating cycles and paths in the diagnose routines.
175 Elab_Position : Natural;
176 -- Initialized to zero. Set non-zero when a unit is chosen and
177 -- placed in the elaboration order. The value represents the
178 -- ordinal position in the elaboration order.
182 package UNR is new Table.Table (
183 Table_Component_Type => Unit_Node_Record,
184 Table_Index_Type => Unit_Id,
185 Table_Low_Bound => First_Unit_Entry,
186 Table_Initial => 500,
187 Table_Increment => 200,
188 Table_Name => "UNR");
191 -- Head of list of items with no predecessors
194 -- Number of entries not yet dealt with
197 -- Current unit, set by Gather_Dependencies, and picked up in Build_Link
198 -- to set the Reason_Unit field of the created dependency link.
200 Num_Chosen : Natural := 0;
201 -- Number of units chosen in the elaboration order so far
203 -----------------------
204 -- Local Subprograms --
205 -----------------------
207 function Better_Choice (U1, U2 : Unit_Id) return Boolean;
208 -- U1 and U2 are both permitted candidates for selection as the next unit
209 -- to be elaborated. This function determines whether U1 is a better choice
210 -- than U2, i.e. should be elaborated in preference to U2, based on a set
211 -- of heuristics that establish a friendly and predictable order (see body
212 -- for details). The result is True if U1 is a better choice than U2, and
213 -- False if it is a worse choice, or there is no preference between them.
219 Ea_Id : Elab_All_Id := No_Elab_All_Link);
220 -- Establish a successor link, Before must be elaborated before After,
221 -- and the reason for the link is R. Ea_Id is the contents to be placed
222 -- in the Elab_All_Link of the entry.
224 procedure Choose (Chosen : Unit_Id);
225 -- Chosen is the next entry chosen in the elaboration order. This
226 -- procedure updates all data structures appropriately.
228 function Corresponding_Body (U : Unit_Id) return Unit_Id;
229 pragma Inline (Corresponding_Body);
230 -- Given a unit which is a spec for which there is a separate body,
231 -- return the unit id of the body. It is an error to call this routine
232 -- with a unit that is not a spec, or which does not have a separate body.
234 function Corresponding_Spec (U : Unit_Id) return Unit_Id;
235 pragma Inline (Corresponding_Spec);
236 -- Given a unit which is a body for which there is a separate spec,
237 -- return the unit id of the spec. It is an error to call this routine
238 -- with a unit that is not a body, or which does not have a separate spec.
240 procedure Diagnose_Elaboration_Problem;
241 -- Called when no elaboration order can be found. Outputs an appropriate
242 -- diagnosis of the problem, and then abandons the bind.
244 procedure Elab_All_Links
247 Reason : Succ_Reason;
249 -- Used to compute the transitive closure of elaboration links for an
250 -- Elaborate_All pragma (Reason = Elab_All) or for an indication of
251 -- Elaborate_All_Desirable (Reason = Elab_Desirable). Unit After has
252 -- a pragma Elaborate_All or the front end has determined that a reference
253 -- probably requires Elaborate_All is required, and unit Before must be
254 -- previously elaborated. First a link is built making sure that unit
255 -- Before is elaborated before After, then a recursive call ensures that
256 -- we also build links for any units needed by Before (i.e. these units
257 -- must/should also be elaborated before After). Link is used to build
258 -- a chain of Elab_All_Entries to explain the reason for a link. The
259 -- value passed is the chain so far.
261 procedure Elab_Error_Msg (S : Successor_Id);
262 -- Given a successor link, outputs an error message of the form
263 -- "& must be elaborated before & ..." where ... is the reason.
265 procedure Gather_Dependencies;
266 -- Compute dependencies, building the Succ and UNR tables
268 function Make_Elab_Entry
269 (Unam : Unit_Name_Type;
272 -- Make an Elab_All_Entries table entry with the given Unam and Link.
274 function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id;
275 -- This function uses the Info field set in the names table to obtain
276 -- the unit Id of a unit, given its name id value.
278 function Worse_Choice (U1, U2 : Unit_Id) return Boolean;
279 -- This is like Better_Choice, and has the same interface, but returns
280 -- true if U1 is a worse choice than U2 in the sense of the -h (horrible
281 -- elaboration order) switch. We still have to obey Ada rules, so it is
282 -- not quite the direct inverse of Better_Choice.
284 procedure Write_Dependencies;
285 -- Write out dependencies (called only if appropriate option is set)
287 procedure Write_Elab_All_Chain (S : Successor_Id);
288 -- If the reason for the link S is Elaborate_All or Elaborate_Desirable,
289 -- then this routine will output the "needed by" explanation chain.
295 function Better_Choice (U1, U2 : Unit_Id) return Boolean is
297 function Body_Unit (U : Unit_Id) return Boolean;
298 -- Determines if given unit is a body
300 function Waiting_Body (U : Unit_Id) return Boolean;
301 -- Determines if U is a waiting body, defined as a body which has
302 -- not been elaborated, but whose spec has been elaborated.
304 function Body_Unit (U : Unit_Id) return Boolean is
306 return Units.Table (U).Utype = Is_Body
307 or else Units.Table (U).Utype = Is_Body_Only;
310 function Waiting_Body (U : Unit_Id) return Boolean is
312 return Units.Table (U).Utype = Is_Body
313 and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
316 -- Start of processing for Better_Choice
318 -- Note: the checks here are applied in sequence, and the ordering is
319 -- significant (i.e. the more important criteria are applied first).
322 -- Prefer a waiting body to any other case
324 if Waiting_Body (U1) and not Waiting_Body (U2) then
327 elsif Waiting_Body (U2) and not Waiting_Body (U1) then
330 -- Prefer a predefined unit to a non-predefined unit
332 elsif Units.Table (U1).Predefined
333 and not Units.Table (U2).Predefined
337 elsif Units.Table (U2).Predefined
338 and not Units.Table (U1).Predefined
342 -- Prefer an internal unit to a non-internal unit
344 elsif Units.Table (U1).Internal
345 and not Units.Table (U2).Internal
349 elsif Units.Table (U2).Internal
350 and not Units.Table (U1).Internal
354 -- Prefer a body to a spec
356 elsif Body_Unit (U1) and not Body_Unit (U2) then
359 elsif Body_Unit (U2) and not Body_Unit (U1) then
362 -- If both are waiting bodies, then prefer the one whose spec is
363 -- more recently elaborated. Consider the following:
369 -- The normal waiting body preference would have placed the body of
370 -- A before the spec of B if it could. Since it could not, there it
371 -- must be the case that A depends on B. It is therefore a good idea
372 -- to put the body of B first.
374 elsif Waiting_Body (U1) and then Waiting_Body (U2) then
376 UNR.Table (Corresponding_Spec (U1)).Elab_Position >
377 UNR.Table (Corresponding_Spec (U2)).Elab_Position;
379 -- Otherwise decide on the basis of alphabetical order
382 return Uname_Less (Units.Table (U1).Uname, Units.Table (U2).Uname);
394 Ea_Id : Elab_All_Id := No_Elab_All_Link)
400 Succ.Table (Succ.Last).Before := Before;
401 Succ.Table (Succ.Last).Next := UNR.Table (Before).Successors;
402 UNR.Table (Before).Successors := Succ.Last;
403 Succ.Table (Succ.Last).Reason := R;
404 Succ.Table (Succ.Last).Reason_Unit := Cur_Unit;
405 Succ.Table (Succ.Last).Elab_All_Link := Ea_Id;
407 -- Deal with special Elab_Body case. If the After of this link is
408 -- a body whose spec has Elaborate_All set, and this is not the link
409 -- directly from the body to the spec, then we make the After of the
410 -- link reference its spec instead, marking the link appropriately.
412 if Units.Table (After).Utype = Is_Body then
413 Cspec := Corresponding_Spec (After);
415 if Units.Table (Cspec).Elaborate_Body
416 and then Cspec /= Before
418 Succ.Table (Succ.Last).After := Cspec;
419 Succ.Table (Succ.Last).Elab_Body := True;
420 UNR.Table (Cspec).Num_Pred := UNR.Table (Cspec).Num_Pred + 1;
425 -- Fall through on normal case
427 Succ.Table (Succ.Last).After := After;
428 Succ.Table (Succ.Last).Elab_Body := False;
429 UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1;
436 procedure Choose (Chosen : Unit_Id) is
442 Write_Str ("Choosing Unit ");
443 Write_Unit_Name (Units.Table (Chosen).Uname);
447 -- Add to elaboration order. Note that units having no elaboration
448 -- code are not treated specially yet. The special casing of this
449 -- is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile
450 -- we need them here, because the object file list is also driven
451 -- by the contents of the Elab_Order table.
453 Elab_Order.Increment_Last;
454 Elab_Order.Table (Elab_Order.Last) := Chosen;
456 -- Remove from No_Pred list. This is a little inefficient and may
457 -- be we should doubly link the list, but it will do for now!
459 if No_Pred = Chosen then
460 No_Pred := UNR.Table (Chosen).Nextnp;
463 -- Note that we just ignore the situation where it does not
464 -- appear in the No_Pred list, this happens in calls from the
465 -- Diagnose_Elaboration_Problem routine, where cycles are being
466 -- removed arbitrarily from the graph.
469 while U /= No_Unit_Id loop
470 if UNR.Table (U).Nextnp = Chosen then
471 UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp;
475 U := UNR.Table (U).Nextnp;
479 -- For all successors, decrement the number of predecessors, and
480 -- if it becomes zero, then add to no predecessor list.
482 S := UNR.Table (Chosen).Successors;
484 while S /= No_Successor loop
485 U := Succ.Table (S).After;
486 UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1;
489 Write_Str (" decrementing Num_Pred for unit ");
490 Write_Unit_Name (Units.Table (U).Uname);
491 Write_Str (" new value = ");
492 Write_Int (Int (UNR.Table (U).Num_Pred));
496 if UNR.Table (U).Num_Pred = 0 then
497 UNR.Table (U).Nextnp := No_Pred;
501 S := Succ.Table (S).Next;
504 -- All done, adjust number of units left count and set elaboration pos
506 Num_Left := Num_Left - 1;
507 Num_Chosen := Num_Chosen + 1;
508 UNR.Table (Chosen).Elab_Position := Num_Chosen;
509 Units.Table (Chosen).Elab_Position := Num_Chosen;
511 -- If we just chose a spec with Elaborate_Body set, then we
512 -- must immediately elaborate the body, before any other units.
514 if Units.Table (Chosen).Elaborate_Body then
516 -- If the unit is a spec only, then there is no body. This is a bit
517 -- odd given that Elaborate_Body is here, but it is valid in an
518 -- RCI unit, where we only have the interface in the stub bind.
520 if Units.Table (Chosen).Utype = Is_Spec_Only
521 and then Units.Table (Chosen).RCI
525 Choose (Corresponding_Body (Chosen));
530 ------------------------
531 -- Corresponding_Body --
532 ------------------------
534 -- Currently if the body and spec are separate, then they appear as
535 -- two separate units in the same ALI file, with the body appearing
536 -- first and the spec appearing second.
538 function Corresponding_Body (U : Unit_Id) return Unit_Id is
540 pragma Assert (Units.Table (U).Utype = Is_Spec);
542 end Corresponding_Body;
544 ------------------------
545 -- Corresponding_Spec --
546 ------------------------
548 -- Currently if the body and spec are separate, then they appear as
549 -- two separate units in the same ALI file, with the body appearing
550 -- first and the spec appearing second.
552 function Corresponding_Spec (U : Unit_Id) return Unit_Id is
554 pragma Assert (Units.Table (U).Utype = Is_Body);
556 end Corresponding_Spec;
558 ----------------------------------
559 -- Diagnose_Elaboration_Problem --
560 ----------------------------------
562 procedure Diagnose_Elaboration_Problem is
564 function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean;
565 -- Recursive routine used to find a path from node Ufrom to node Uto.
566 -- If a path exists, returns True and outputs an appropriate set of
567 -- error messages giving the path. Also calls Choose for each of the
568 -- nodes so that they get removed from the remaining set. There are
569 -- two cases of calls, either Ufrom = Uto for an attempt to find a
570 -- cycle, or Ufrom is a spec and Uto the corresponding body for the
571 -- case of an unsatisfiable Elaborate_Body pragma. ML is the minimum
572 -- acceptable length for a path.
578 function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is
580 function Find_Link (U : Unit_Id; PL : Nat) return Boolean;
581 -- This is the inner recursive routine, it determines if a path
582 -- exists from U to Uto, and if so returns True and outputs the
583 -- appropriate set of error messages. PL is the path length
589 function Find_Link (U : Unit_Id; PL : Nat) return Boolean is
593 -- Recursion ends if we are at terminating node and the path
594 -- is sufficiently long, generate error message and return True.
596 if U = Uto and then PL >= ML then
600 -- All done if already visited, otherwise mark as visited
602 elsif UNR.Table (U).Visited then
605 -- Otherwise mark as visited and look at all successors
608 UNR.Table (U).Visited := True;
610 S := UNR.Table (U).Successors;
611 while S /= No_Successor loop
612 if Find_Link (Succ.Table (S).After, PL + 1) then
618 S := Succ.Table (S).Next;
621 -- Falling through means this does not lead to a path
627 -- Start of processing for Find_Path
630 -- Initialize all non-chosen nodes to not visisted yet
632 for U in Units.First .. Units.Last loop
633 UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0;
636 -- Now try to find the path
638 return Find_Link (Ufrom, 0);
641 -- Start of processing for Diagnose_Elaboration_Error
646 -- Output state of things if debug flag N set
655 Write_Str ("Diagnose_Elaboration_Problem called");
657 Write_Str ("List of remaining unchosen units and predecessors");
660 for U in Units.First .. Units.Last loop
661 if UNR.Table (U).Elab_Position = 0 then
662 NP := UNR.Table (U).Num_Pred;
664 Write_Str (" Unchosen unit: #");
667 Write_Unit_Name (Units.Table (U).Uname);
668 Write_Str (" (Num_Pred = ");
674 if Units.Table (U).Elaborate_Body then
676 (" (not chosen because of Elaborate_Body)");
679 Write_Str (" ****************** why not chosen?");
684 -- Search links list to find unchosen predecessors
686 for S in Succ.First .. Succ.Last loop
688 SL : Successor_Link renames Succ.Table (S);
692 and then UNR.Table (SL.Before).Elab_Position = 0
694 Write_Str (" unchosen predecessor: #");
695 Write_Int (Int (SL.Before));
697 Write_Unit_Name (Units.Table (SL.Before).Uname);
705 Write_Str (" **************** Num_Pred value wrong!");
713 -- Output the header for the error, and manually increment the
714 -- error count. We are using Error_Msg_Output rather than Error_Msg
715 -- here for two reasons:
717 -- This is really only one error, not one for each line
718 -- We want this output on standard output since it is voluminous
720 -- But we do need to deal with the error count manually in this case
722 Errors_Detected := Errors_Detected + 1;
723 Error_Msg_Output ("elaboration circularity detected", Info => False);
725 -- Try to find cycles starting with any of the remaining nodes that have
726 -- not yet been chosen. There must be at least one (there is some reason
727 -- we are being called!)
729 for U in Units.First .. Units.Last loop
730 if UNR.Table (U).Elab_Position = 0 then
731 if Find_Path (U, U, 1) then
732 raise Unrecoverable_Error;
737 -- We should never get here, since we were called for some reason,
738 -- and we should have found and eliminated at least one bad path.
742 end Diagnose_Elaboration_Problem;
748 procedure Elab_All_Links
751 Reason : Succ_Reason;
755 if UNR.Table (Before).Visited then
759 -- Build the direct link for Before
761 UNR.Table (Before).Visited := True;
762 Build_Link (Before, After, Reason, Link);
764 -- Process all units with'ed by Before recursively
767 Units.Table (Before).First_With .. Units.Table (Before).Last_With
769 -- Skip if no ALI file for this with, happens with certain
770 -- specialized generic files that do not get compiled.
772 if Withs.Table (W).Afile /= No_File then
775 (Unit_Id_Of (Withs.Table (W).Uname),
778 Make_Elab_Entry (Withs.Table (W).Uname, Link));
782 -- Process corresponding body, if there is one
784 if Units.Table (Before).Utype = Is_Spec then
786 (Corresponding_Body (Before),
789 (Units.Table (Corresponding_Body (Before)).Uname, Link));
797 procedure Elab_Error_Msg (S : Successor_Id) is
798 SL : Successor_Link renames Succ.Table (S);
801 -- Nothing to do if internal unit involved and no -de flag
805 (Is_Internal_File_Name (Units.Table (SL.Before).Sfile)
807 Is_Internal_File_Name (Units.Table (SL.After).Sfile))
812 -- Here we want to generate output
814 Error_Msg_Name_1 := Units.Table (SL.Before).Uname;
817 Error_Msg_Name_2 := Units.Table (Corresponding_Body (SL.After)).Uname;
819 Error_Msg_Name_2 := Units.Table (SL.After).Uname;
822 Error_Msg_Output (" & must be elaborated before &", Info => True);
824 Error_Msg_Name_1 := Units.Table (SL.Reason_Unit).Uname;
829 (" reason: with clause",
834 (" reason: pragma Elaborate in unit &",
839 (" reason: pragma Elaborate_All in unit &",
842 when Elab_Desirable =>
844 (" reason: Elaborate_All probably needed in unit &",
848 (" recompile & with -gnatwl for full details",
853 (" reason: spec always elaborated before body",
857 Write_Elab_All_Chain (S);
860 Error_Msg_Name_1 := Units.Table (SL.Before).Uname;
861 Error_Msg_Name_2 := Units.Table (SL.After).Uname;
863 (" & must therefore be elaborated before &",
866 Error_Msg_Name_1 := Units.Table (SL.After).Uname;
868 (" (because & has a pragma Elaborate_Body)",
875 ---------------------
876 -- Find_Elab_Order --
877 ---------------------
879 procedure Find_Elab_Order is
881 Best_So_Far : Unit_Id;
885 Num_Left := Int (Units.Last - Units.First + 1);
887 -- Initialize unit table for elaboration control
889 for U in Units.First .. Units.Last loop
891 UNR.Table (UNR.Last).Successors := No_Successor;
892 UNR.Table (UNR.Last).Num_Pred := 0;
893 UNR.Table (UNR.Last).Nextnp := No_Unit_Id;
894 UNR.Table (UNR.Last).Elab_Order := 0;
895 UNR.Table (UNR.Last).Elab_Position := 0;
898 -- Gather dependencies and output them if option set
902 -- Output elaboration dependencies if option is set
904 if Elab_Dependency_Output or Debug_Flag_E then
908 -- Initialize the no predecessor list
910 No_Pred := No_Unit_Id;
912 for U in UNR.First .. UNR.Last loop
913 if UNR.Table (U).Num_Pred = 0 then
914 UNR.Table (U).Nextnp := No_Pred;
919 -- OK, now we determine the elaboration order proper. All we do is to
920 -- select the best choice from the no predecessor list until all the
921 -- nodes have been chosen.
924 -- If there are no nodes with predecessors, then either we are
925 -- done, as indicated by Num_Left being set to zero, or we have
926 -- a circularity. In the latter case, diagnose the circularity,
927 -- removing it from the graph and continue
929 Get_No_Pred : while No_Pred = No_Unit_Id loop
930 exit Outer when Num_Left < 1;
931 Diagnose_Elaboration_Problem;
932 end loop Get_No_Pred;
935 Best_So_Far := No_Unit_Id;
937 -- Loop to choose best entry in No_Pred list
939 No_Pred_Search : loop
941 Write_Str (" considering choice of ");
942 Write_Unit_Name (Units.Table (U).Uname);
945 if Units.Table (U).Elaborate_Body then
947 (" Elaborate_Body = True, Num_Pred for body = ");
949 (Int (UNR.Table (Corresponding_Body (U)).Num_Pred));
952 (" Elaborate_Body = False");
958 -- This is a candididate to be considered for choice
960 if Best_So_Far = No_Unit_Id
961 or else ((not Pessimistic_Elab_Order)
962 and then Better_Choice (U, Best_So_Far))
963 or else (Pessimistic_Elab_Order
964 and then Worse_Choice (U, Best_So_Far))
967 Write_Str (" tentatively chosen (best so far)");
974 U := UNR.Table (U).Nextnp;
975 exit No_Pred_Search when U = No_Unit_Id;
976 end loop No_Pred_Search;
978 -- If no candididate chosen, it means that no unit has No_Pred = 0,
979 -- but there are units left, hence we have a circular dependency,
980 -- which we will get Diagnose_Elaboration_Problem to diagnose it.
982 if Best_So_Far = No_Unit_Id then
983 Diagnose_Elaboration_Problem;
985 -- Otherwise choose the best candidate found
988 Choose (Best_So_Far);
994 -------------------------
995 -- Gather_Dependencies --
996 -------------------------
998 procedure Gather_Dependencies is
999 Withed_Unit : Unit_Id;
1002 -- Loop through all units
1004 for U in Units.First .. Units.Last loop
1007 -- If there is a body and a spec, then spec must be elaborated first
1008 -- Note that the corresponding spec immediately follows the body
1010 if Units.Table (U).Utype = Is_Body then
1011 Build_Link (Corresponding_Spec (U), U, Spec_First);
1014 -- Process WITH references for this unit ignoring generic units
1016 for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop
1017 if Withs.Table (W).Sfile /= No_File then
1019 -- Check for special case of withing a unit that does not
1020 -- exist any more. If the unit was completely missing we would
1021 -- already have detected this, but a nasty case arises when we
1022 -- have a subprogram body with no spec, and some obsolete unit
1023 -- with's a previous (now disappeared) spec.
1025 if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then
1026 Error_Msg_Name_1 := Units.Table (U).Sfile;
1027 Error_Msg_Name_2 := Withs.Table (W).Uname;
1028 Error_Msg ("% depends on & which no longer exists");
1033 Unit_Id (Unit_Id_Of (Withs.Table (W).Uname));
1035 -- Pragma Elaborate_All case, for this we use the recursive
1036 -- Elab_All_Links procedure to establish the links.
1038 if Withs.Table (W).Elaborate_All then
1040 -- Reset flags used to stop multiple visits to a given node
1042 for Uref in UNR.First .. UNR.Last loop
1043 UNR.Table (Uref).Visited := False;
1046 -- Now establish all the links we need
1049 (Withed_Unit, U, Elab_All,
1051 (Withs.Table (W).Uname, No_Elab_All_Link));
1053 -- Elaborate_All_Desirable case, for this we establish the
1054 -- same links as above, but with a different reason.
1056 elsif Withs.Table (W).Elab_All_Desirable then
1058 -- Reset flags used to stop multiple visits to a given node
1060 for Uref in UNR.First .. UNR.Last loop
1061 UNR.Table (Uref).Visited := False;
1064 -- Now establish all the links we need
1067 (Withed_Unit, U, Elab_Desirable,
1069 (Withs.Table (W).Uname, No_Elab_All_Link));
1071 -- Pragma Elaborate case. We must build a link for the withed
1072 -- unit itself, and also the corresponding body if there is one
1074 -- However, skip this processing if there is no ALI file for
1075 -- the WITH entry, because this means it is a generic (even
1076 -- when we fix the generics so that an ALI file is present,
1077 -- we probably still will have no ALI file for unchecked
1078 -- and other special cases).
1080 elsif Withs.Table (W).Elaborate
1081 and then Withs.Table (W).Afile /= No_File
1083 Build_Link (Withed_Unit, U, Withed);
1085 if Units.Table (Withed_Unit).Utype = Is_Spec then
1087 (Corresponding_Body (Withed_Unit), U, Elab);
1090 -- Case of normal WITH with no elaboration pragmas, just
1091 -- build the single link to the directly referenced unit
1094 Build_Link (Withed_Unit, U, Withed);
1102 end Gather_Dependencies;
1104 ---------------------
1105 -- Make_Elab_Entry --
1106 ---------------------
1108 function Make_Elab_Entry
1109 (Unam : Unit_Name_Type;
1114 Elab_All_Entries.Increment_Last;
1115 Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam;
1116 Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link;
1117 return Elab_All_Entries.Last;
1118 end Make_Elab_Entry;
1124 function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
1125 Info : constant Int := Get_Name_Table_Info (Uname);
1128 pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
1129 return Unit_Id (Info);
1136 function Worse_Choice (U1, U2 : Unit_Id) return Boolean is
1138 function Body_Unit (U : Unit_Id) return Boolean;
1139 -- Determines if given unit is a body
1141 function Waiting_Body (U : Unit_Id) return Boolean;
1142 -- Determines if U is a waiting body, defined as a body which has
1143 -- not been elaborated, but whose spec has been elaborated.
1145 function Body_Unit (U : Unit_Id) return Boolean is
1147 return Units.Table (U).Utype = Is_Body
1148 or else Units.Table (U).Utype = Is_Body_Only;
1151 function Waiting_Body (U : Unit_Id) return Boolean is
1153 return Units.Table (U).Utype = Is_Body and then
1154 UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
1157 -- Start of processing for Worse_Choice
1159 -- Note: the checks here are applied in sequence, and the ordering is
1160 -- significant (i.e. the more important criteria are applied first).
1163 -- If either unit is internal, then use Better_Choice, since the
1164 -- language requires that predefined units not mess up in the choice
1165 -- of elaboration order, and for internal units, any problems are
1166 -- ours and not the programmers.
1168 if Units.Table (U1).Internal or else Units.Table (U2).Internal then
1169 return Better_Choice (U1, U2);
1171 -- Prefer anything else to a waiting body (!)
1173 elsif Waiting_Body (U1) and not Waiting_Body (U2) then
1176 elsif Waiting_Body (U2) and not Waiting_Body (U1) then
1179 -- Prefer a spec to a body (!)
1181 elsif Body_Unit (U1) and not Body_Unit (U2) then
1184 elsif Body_Unit (U2) and not Body_Unit (U1) then
1187 -- If both are waiting bodies, then prefer the one whose spec is
1188 -- less recently elaborated. Consider the following:
1194 -- The normal waiting body preference would have placed the body of
1195 -- A before the spec of B if it could. Since it could not, there it
1196 -- must be the case that A depends on B. It is therefore a good idea
1197 -- to put the body of B last so that if there is an elaboration order
1198 -- problem, we will find it (that's what horrible order is about)
1200 elsif Waiting_Body (U1) and then Waiting_Body (U2) then
1202 UNR.Table (Corresponding_Spec (U1)).Elab_Position <
1203 UNR.Table (Corresponding_Spec (U2)).Elab_Position;
1205 -- Otherwise decide on the basis of alphabetical order. We do not try
1206 -- to reverse the usual choice here, since it can cause cancelling
1207 -- errors with the other inversions.
1210 return Uname_Less (Units.Table (U1).Uname, Units.Table (U2).Uname);
1214 ------------------------
1215 -- Write_Dependencies --
1216 ------------------------
1218 procedure Write_Dependencies is
1222 (" ELABORATION ORDER DEPENDENCIES");
1226 Info_Prefix_Suppress := True;
1228 for S in Succ_First .. Succ.Last loop
1232 Info_Prefix_Suppress := False;
1234 end Write_Dependencies;
1236 --------------------------
1237 -- Write_Elab_All_Chain --
1238 --------------------------
1240 procedure Write_Elab_All_Chain (S : Successor_Id) is
1241 ST : constant Successor_Link := Succ.Table (S);
1242 After : constant Unit_Name_Type := Units.Table (ST.After).Uname;
1245 Nam : Unit_Name_Type;
1247 First_Name : Boolean := True;
1250 if ST.Reason in Elab_All .. Elab_Desirable then
1251 L := ST.Elab_All_Link;
1252 while L /= No_Elab_All_Link loop
1253 Nam := Elab_All_Entries.Table (L).Needed_By;
1254 Error_Msg_Name_1 := Nam;
1255 Error_Msg_Output (" &", Info => True);
1257 Get_Name_String (Nam);
1259 if Name_Buffer (Name_Len) = 'b' then
1262 (" must be elaborated along with its spec:",
1267 (" which must be elaborated " &
1268 "along with its spec:",
1280 (" which is withed by:",
1285 First_Name := False;
1287 L := Elab_All_Entries.Table (L).Next_Elab;
1290 Error_Msg_Name_1 := After;
1291 Error_Msg_Output (" &", Info => True);
1293 end Write_Elab_All_Chain;