1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, 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;
32 with Output; use Output;
34 with Types; use Types;
36 with System.Case_Util; use System.Case_Util;
42 -- We now have Elab_New, a new elaboration-order algorithm.
44 -- However, any change to elaboration order can break some programs.
45 -- Therefore, we are keeping the old algorithm in place, to be selected
48 -- The new algorithm has the following interesting properties:
50 -- * The static and dynamic models use the same elaboration order. The
51 -- static model might get an error, but if it does not, it will use
52 -- the same order as the dynamic model.
54 -- * Each SCC (see below) is elaborated together; that is, units from
55 -- different SCCs are not interspersed.
57 -- * In particular, this implies that if an SCC contains just a spec and
58 -- the corresponding body, and nothing else, the body will be
59 -- elaborated immediately after the spec. This is expected to result
60 -- in a better elaboration order for most programs, because in this
61 -- case, a call from outside the library unit cannot get ABE.
63 -- * Pragmas Elaborate_All (explicit and implicit) are ignored. Instead,
64 -- we behave as if every legal pragma Elaborate_All were present. That
65 -- is, if it would be legal to have "pragma Elaborate_All(Y);" on X,
66 -- then we behave as if such a pragma exists, even if it does not.
68 Do_Old : constant Boolean := False;
69 Do_New : constant Boolean := True;
70 -- True to enable the old and new algorithms, respectively. Used for
71 -- debugging/experimentation.
73 Doing_New : Boolean := False;
74 -- True if we are currently doing the new algorithm. Print certain
75 -- messages only when doing the "new" elab order algorithm, so we don't get
76 -- duplicates. And use different heuristics in Better_Choice_Optimistic.
78 -- The following data structures are used to represent the graph that is
79 -- used to determine the elaboration order (using a topological sort).
81 -- The following structures are used to record successors. If B is a
82 -- successor of A in this table, it means that A must be elaborated before
83 -- B is elaborated. For example, if Y (body) says "with X;", then Y (body)
84 -- will be a successor of X (spec), and X (spec) will be a predecessor of
87 -- Note that we store the successors of each unit explicitly. We don't
88 -- store the predecessors, but we store a count of them.
90 -- The basic algorithm is to first compute a directed graph of units (type
91 -- Unit_Node_Record, below), with successors as edges. A unit is "ready"
92 -- (to be chosen as the next to be elaborated) if it has no predecessors
93 -- that have not yet been chosen. We use heuristics to decide which of the
94 -- ready units should be elaborated next, and "choose" that one (which
95 -- means we append it to the elaboration-order table).
97 type Successor_Id is new Nat;
98 -- Identification of single successor entry
100 No_Successor : constant Successor_Id := 0;
101 -- Used to indicate end of list of successors
103 type Elab_All_Id is new Nat;
104 -- Identification of Elab_All entry link
106 No_Elab_All_Link : constant Elab_All_Id := 0;
107 -- Used to indicate end of list
109 -- Succ_Reason indicates the reason for a particular elaboration link
113 -- After directly with's Before, so the spec of Before must be
114 -- elaborated before After is elaborated.
117 -- Before and After come from a pair of lines in the forced-elaboration-
121 -- After directly mentions Before in a pragma Elaborate, so the body of
122 -- Before must be elaborated before After is elaborated.
125 -- After either mentions Before directly in a pragma Elaborate_All, or
126 -- mentions a third unit, X, which itself requires that Before be
127 -- elaborated before unit X is elaborated. The Elab_All_Link list traces
128 -- the dependencies in the latter case.
131 -- This is just like Elab_All, except that the Elaborate_All was not
132 -- explicitly present in the source, but rather was created by the front
133 -- end, which decided that it was "desirable".
136 -- This is just like Elab, except that the Elaborate was not explicitly
137 -- present in the source, but rather was created by the front end, which
138 -- decided that it was "desirable".
141 -- After is a body, and Before is the corresponding spec
143 -- Successor_Link contains the information for one link
145 type Successor_Link is record
153 -- Next successor on this list
155 Reason : Succ_Reason;
156 -- Reason for this link
159 -- Set True if this link is needed for the special Elaborate_Body
160 -- processing described below.
162 Reason_Unit : Unit_Id;
163 -- For Reason = Elab, or Elab_All or Elab_Desirable, records the unit
164 -- containing the pragma leading to the link.
166 Elab_All_Link : Elab_All_Id;
167 -- If Reason = Elab_All or Elab_Desirable, then this points to the
168 -- first element in a list of Elab_All entries that record the with
169 -- chain resulting in this particular dependency.
172 -- Note on handling of Elaborate_Body. Basically, if we have a pragma
173 -- Elaborate_Body in a unit, it means that the spec and body have to be
174 -- handled as a single entity from the point of view of determining an
175 -- elaboration order. What we do is to essentially remove the body from
176 -- consideration completely, and transfer all its links (other than the
177 -- spec link) to the spec. Then when the spec gets chosen, we choose the
178 -- body right afterwards. We mark the links that get moved from the body to
179 -- the spec by setting their Elab_Body flag True, so that we can understand
182 Succ_First : constant := 1;
184 package Succ is new Table.Table
185 (Table_Component_Type => Successor_Link,
186 Table_Index_Type => Successor_Id,
187 Table_Low_Bound => Succ_First,
188 Table_Initial => 500,
189 Table_Increment => 200,
190 Table_Name => "Succ");
192 -- For the case of Elaborate_All, the following table is used to record
193 -- chains of with relationships that lead to the Elab_All link. These are
194 -- used solely for diagnostic purposes
196 type Elab_All_Entry is record
197 Needed_By : Unit_Name_Type;
198 -- Name of unit from which referencing unit was with'ed or otherwise
199 -- needed as a result of Elaborate_All or Elaborate_Desirable.
201 Next_Elab : Elab_All_Id;
202 -- Link to next entry on chain (No_Elab_All_Link marks end of list)
205 package Elab_All_Entries is new Table.Table
206 (Table_Component_Type => Elab_All_Entry,
207 Table_Index_Type => Elab_All_Id,
208 Table_Low_Bound => 1,
209 Table_Initial => 2000,
210 Table_Increment => 200,
211 Table_Name => "Elab_All_Entries");
213 type Unit_Id_Array_Ptr is access Unit_Id_Array;
215 -- A Unit_Node_Record is built for each active unit
217 type Unit_Node_Record is record
218 Successors : Successor_Id;
219 -- Pointer to list of links for successor nodes
222 -- Number of predecessors for this unit that have not yet been chosen.
223 -- Normally non-negative, but can go negative in the case of units
224 -- chosen by the diagnose error procedure (when cycles are being removed
228 -- Forward pointer for list of units with no predecessors
231 -- Used in computing transitive closure for Elaborate_All and also in
232 -- locating cycles and paths in the diagnose routines.
235 -- Initialized to zero. Set non-zero when a unit is chosen and placed in
236 -- the elaboration order. The value represents the ordinal position in
237 -- the elaboration order.
239 -- The following are for Elab_New. We compute the strongly connected
240 -- components (SCCs) of the directed graph of units. The edges are the
241 -- Successors, which do not include pragmas Elaborate_All (explicit or
242 -- implicit) in Elab_New. In addition, we assume there is a edge
243 -- pointing from a body to its corresponding spec; this edge is not
244 -- included in Successors, because of course a spec is elaborated BEFORE
245 -- its body, not after.
248 -- Each unit points to the root of its SCC, which is just an arbitrary
249 -- member of the SCC. Two units are in the same SCC if and only if their
250 -- SCC_Roots are equal. U is the root of its SCC if and only if
253 Nodes : Unit_Id_Array_Ptr;
254 -- Present only in the root of an SCC. This is the set of units in the
255 -- SCC, in no particular order.
258 -- Present only in the root of an SCC. This is the number of predecessor
259 -- units of the SCC that are in other SCCs, and that have not yet been
262 Validate_Seen : Boolean := False;
263 -- See procedure Validate below
266 package UNR is new Table.Table
267 (Table_Component_Type => Unit_Node_Record,
268 Table_Index_Type => Unit_Id,
269 Table_Low_Bound => First_Unit_Entry,
270 Table_Initial => 500,
271 Table_Increment => 200,
272 Table_Name => "UNR");
275 -- Head of list of items with no predecessors
278 -- Number of entries not yet dealt with
281 -- Current unit, set by Gather_Dependencies, and picked up in Build_Link to
282 -- set the Reason_Unit field of the created dependency link.
285 -- Number of units chosen in the elaboration order so far
287 Diagnose_Elaboration_Problem_Called : Boolean := False;
288 -- True if Diagnose_Elaboration_Problem was called. Used in an assertion.
290 -----------------------
291 -- Local Subprograms --
292 -----------------------
294 function Debug_Flag_Older return Boolean;
295 function Debug_Flag_Old return Boolean;
296 -- True if debug flags select the old or older algorithms. Pretty much any
297 -- change to elaboration order can break some programs. For example,
298 -- programs can depend on elaboration order even without failing
299 -- access-before-elaboration checks. A trivial example is a program that
300 -- prints text during elaboration. Therefore, we have flags to revert to
301 -- the old(er) algorithms.
303 procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean);
304 -- Assert that certain properties are true
306 function Better_Choice_Optimistic
308 U2 : Unit_Id) return Boolean;
309 -- U1 and U2 are both permitted candidates for selection as the next unit
310 -- to be elaborated. This function determines whether U1 is a better choice
311 -- than U2, i.e. should be elaborated in preference to U2, based on a set
312 -- of heuristics that establish a friendly and predictable order (see body
313 -- for details). The result is True if U1 is a better choice than U2, and
314 -- False if it is a worse choice, or there is no preference between them.
316 function Better_Choice_Pessimistic
318 U2 : Unit_Id) return Boolean;
319 -- This is like Better_Choice_Optimistic, and has the same interface, but
320 -- returns true if U1 is a worse choice than U2 in the sense of the -p
321 -- (pessimistic elaboration order) switch. We still have to obey Ada rules,
322 -- so it is not quite the direct inverse of Better_Choice_Optimistic.
324 function Better_Choice (U1 : Unit_Id; U2 : Unit_Id) return Boolean;
325 -- Calls Better_Choice_Optimistic or Better_Choice_Pessimistic as
326 -- appropriate. Also takes care of the U2 = No_Unit_Id case.
332 Ea_Id : Elab_All_Id := No_Elab_All_Link);
333 -- Establish a successor link, Before must be elaborated before After, and
334 -- the reason for the link is R. Ea_Id is the contents to be placed in the
335 -- Elab_All_Link of the entry.
338 (Elab_Order : in out Unit_Id_Table;
341 -- Chosen is the next entry chosen in the elaboration order. This procedure
342 -- updates all data structures appropriately.
344 function Corresponding_Body (U : Unit_Id) return Unit_Id;
345 pragma Inline (Corresponding_Body);
346 -- Given a unit that is a spec for which there is a separate body, return
347 -- the unit id of the body. It is an error to call this routine with a unit
348 -- that is not a spec, or that does not have a separate body.
350 function Corresponding_Spec (U : Unit_Id) return Unit_Id;
351 pragma Inline (Corresponding_Spec);
352 -- Given a unit that is a body for which there is a separate spec, return
353 -- the unit id of the spec. It is an error to call this routine with a unit
354 -- that is not a body, or that does not have a separate spec.
356 procedure Diagnose_Elaboration_Problem
357 (Elab_Order : in out Unit_Id_Table);
358 pragma No_Return (Diagnose_Elaboration_Problem);
359 -- Called when no elaboration order can be found. Outputs an appropriate
360 -- diagnosis of the problem, and then abandons the bind.
362 procedure Elab_All_Links
365 Reason : Succ_Reason;
367 -- Used to compute the transitive closure of elaboration links for an
368 -- Elaborate_All pragma (Reason = Elab_All) or for an indication of
369 -- Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has a
370 -- pragma Elaborate_All or the front end has determined that a reference
371 -- probably requires Elaborate_All, and unit Before must be previously
372 -- elaborated. First a link is built making sure that unit Before is
373 -- elaborated before After, then a recursive call ensures that we also
374 -- build links for any units needed by Before (i.e. these units must/should
375 -- also be elaborated before After). Link is used to build a chain of
376 -- Elab_All_Entries to explain the reason for a link. The value passed is
379 procedure Elab_Error_Msg (S : Successor_Id);
380 -- Given a successor link, outputs an error message of the form
381 -- "$ must be elaborated before $ ..." where ... is the reason.
383 procedure Force_Elab_Order;
384 -- Gather dependencies from the forced-elaboration-order file (-f switch)
386 procedure Gather_Dependencies;
387 -- Compute dependencies, building the Succ and UNR tables
390 -- Initialize global data structures in this package body
392 function Is_Body_Unit (U : Unit_Id) return Boolean;
393 pragma Inline (Is_Body_Unit);
394 -- Determines if given unit is a body
396 function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean;
397 -- Returns True if corresponding unit is Pure or Preelaborate. Includes
398 -- dealing with testing flags on spec if it is given a body.
400 function Is_Waiting_Body (U : Unit_Id) return Boolean;
401 pragma Inline (Is_Waiting_Body);
402 -- Determines if U is a waiting body, defined as a body that has
403 -- not been elaborated, but whose spec has been elaborated.
405 function Make_Elab_All_Entry
406 (Unam : Unit_Name_Type;
407 Link : Elab_All_Id) return Elab_All_Id;
408 -- Make an Elab_All_Entries table entry with the given Unam and Link
410 function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id;
411 -- This function uses the Info field set in the names table to obtain
412 -- the unit Id of a unit, given its name id value.
414 procedure Write_Closure (Order : Unit_Id_Array);
415 -- Write the closure. This is for the -R and -Ra switches, "list closure
418 procedure Write_Dependencies;
419 -- Write out dependencies (called only if appropriate option is set)
421 procedure Write_Elab_All_Chain (S : Successor_Id);
422 -- If the reason for the link S is Elaborate_All or Elaborate_Desirable,
423 -- then this routine will output the "needed by" explanation chain.
425 procedure Write_Elab_Order (Order : Unit_Id_Array; Title : String);
426 -- Display elaboration order. This is for the -l switch. Title is a heading
427 -- to print; an empty string is passed to indicate Zero_Formatting.
431 -- Implementation of the new algorithm
433 procedure Write_SCC (U : Unit_Id);
434 -- Write the unit names of the units in the SCC in which U lives
436 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table);
438 Elab_Cycle_Found : Boolean := False;
439 -- Set True if Find_Elab_Order found a cycle (usually an illegal pragma
440 -- Elaborate_All, explicit or implicit).
442 function SCC (U : Unit_Id) return Unit_Id;
443 -- The root of the strongly connected component containing U
445 function SCC_Num_Pred (U : Unit_Id) return Int;
446 -- The SCC_Num_Pred of the SCC in which U lives
448 function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr;
449 -- The nodes of the strongly connected component containing U
457 -- Implementation of the old algorithm
459 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table);
463 -- Most of the code is shared between old and new; such code is outside
464 -- packages Elab_Old and Elab_New.
470 function Better_Choice (U1 : Unit_Id; U2 : Unit_Id) return Boolean is
471 pragma Assert (U1 /= No_Unit_Id);
473 if U2 = No_Unit_Id then
477 if Pessimistic_Elab_Order then
478 return Better_Choice_Pessimistic (U1, U2);
480 return Better_Choice_Optimistic (U1, U2);
484 ------------------------------
485 -- Better_Choice_Optimistic --
486 ------------------------------
488 function Better_Choice_Optimistic
490 U2 : Unit_Id) return Boolean
492 UT1 : Unit_Record renames Units.Table (U1);
493 UT2 : Unit_Record renames Units.Table (U2);
497 Write_Str ("Better_Choice_Optimistic (");
498 Write_Unit_Name (UT1.Uname);
500 Write_Unit_Name (UT2.Uname);
504 -- Note: the checks here are applied in sequence, and the ordering is
505 -- significant (i.e. the more important criteria are applied first).
507 -- Prefer a waiting body to one that is not a waiting body
509 if Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
511 Write_Line (" True: u1 is waiting body, u2 is not");
516 elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
518 Write_Line (" False: u2 is waiting body, u1 is not");
523 -- Prefer a predefined unit to a non-predefined unit
525 elsif UT1.Predefined and then not UT2.Predefined then
527 Write_Line (" True: u1 is predefined, u2 is not");
532 elsif UT2.Predefined and then not UT1.Predefined then
534 Write_Line (" False: u2 is predefined, u1 is not");
539 -- Prefer an internal unit to a non-internal unit
541 elsif UT1.Internal and then not UT2.Internal then
543 Write_Line (" True: u1 is internal, u2 is not");
547 elsif UT2.Internal and then not UT1.Internal then
549 Write_Line (" False: u2 is internal, u1 is not");
554 -- Prefer a pure or preelaborated unit to one that is not. Pure should
555 -- come before preelaborated.
557 elsif Is_Pure_Or_Preelab_Unit (U1)
559 Is_Pure_Or_Preelab_Unit (U2)
562 Write_Line (" True: u1 is pure/preelab, u2 is not");
567 elsif Is_Pure_Or_Preelab_Unit (U2)
569 Is_Pure_Or_Preelab_Unit (U1)
572 Write_Line (" False: u2 is pure/preelab, u1 is not");
577 -- Prefer a body to a spec
579 elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
581 Write_Line (" True: u1 is body, u2 is not");
586 elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
588 Write_Line (" False: u2 is body, u1 is not");
593 -- If both are waiting bodies, then prefer the one whose spec is more
594 -- recently elaborated. Consider the following:
600 -- The normal waiting body preference would have placed the body of A
601 -- before the spec of B if it could. Since it could not, then it must be
602 -- the case that A depends on B. It is therefore a good idea to put the
605 elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
607 Result : constant Boolean :=
608 UNR.Table (Corresponding_Spec (U1)).Elab_Position >
609 UNR.Table (Corresponding_Spec (U2)).Elab_Position;
613 Write_Line (" True: based on waiting body elab positions");
615 Write_Line (" False: based on waiting body elab positions");
623 -- Remaining choice rules are disabled by Debug flag -do
625 if not Debug_Flag_Older then
627 -- The following deal with the case of specs that have been marked
628 -- as Elaborate_Body_Desirable. We generally want to delay these
629 -- specs as long as possible, so that the bodies have a better chance
630 -- of being elaborated closer to the specs.
632 -- If we have two units, one of which is a spec for which this flag
633 -- is set, and the other is not, we prefer to delay the spec for
634 -- which the flag is set.
636 if not UT1.Elaborate_Body_Desirable
637 and then UT2.Elaborate_Body_Desirable
640 Write_Line (" True: u1 is elab body desirable, u2 is not");
645 elsif not UT2.Elaborate_Body_Desirable
646 and then UT1.Elaborate_Body_Desirable
649 Write_Line (" False: u1 is elab body desirable, u2 is not");
654 -- If we have two specs that are both marked as Elaborate_Body
655 -- desirable, we prefer the one whose body is nearer to being able
656 -- to be elaborated, based on the Num_Pred count. This helps to
657 -- ensure bodies are as close to specs as possible.
659 elsif UT1.Elaborate_Body_Desirable
660 and then UT2.Elaborate_Body_Desirable
663 Result : constant Boolean :=
664 UNR.Table (Corresponding_Body (U1)).Num_Pred <
665 UNR.Table (Corresponding_Body (U2)).Num_Pred;
669 Write_Line (" True based on Num_Pred compare");
671 Write_Line (" False based on Num_Pred compare");
680 -- If we have two specs in the same SCC, choose the one whose body is
681 -- closer to being ready.
684 and then SCC (U1) = SCC (U2)
685 and then Units.Table (U1).Utype = Is_Spec
686 and then Units.Table (U2).Utype = Is_Spec
687 and then UNR.Table (Corresponding_Body (U1)).Num_Pred /=
688 UNR.Table (Corresponding_Body (U2)).Num_Pred
690 if UNR.Table (Corresponding_Body (U1)).Num_Pred <
691 UNR.Table (Corresponding_Body (U2)).Num_Pred
694 Write_Str (" True: same SCC; ");
695 Write_Int (UNR.Table (Corresponding_Body (U1)).Num_Pred);
697 Write_Int (UNR.Table (Corresponding_Body (U2)).Num_Pred);
704 Write_Str (" False: same SCC; ");
705 Write_Int (UNR.Table (Corresponding_Body (U1)).Num_Pred);
707 Write_Int (UNR.Table (Corresponding_Body (U2)).Num_Pred);
715 -- If we fall through, it means that no preference rule applies, so we
716 -- use alphabetical order to at least give a deterministic result.
719 Write_Line (" choose on alpha order");
722 return Uname_Less (UT1.Uname, UT2.Uname);
723 end Better_Choice_Optimistic;
725 -------------------------------
726 -- Better_Choice_Pessimistic --
727 -------------------------------
729 function Better_Choice_Pessimistic
731 U2 : Unit_Id) return Boolean
733 UT1 : Unit_Record renames Units.Table (U1);
734 UT2 : Unit_Record renames Units.Table (U2);
738 Write_Str ("Better_Choice_Pessimistic (");
739 Write_Unit_Name (UT1.Uname);
741 Write_Unit_Name (UT2.Uname);
745 -- Note: the checks here are applied in sequence, and the ordering is
746 -- significant (i.e. the more important criteria are applied first).
748 -- If either unit is predefined or internal, then we use the normal
749 -- Better_Choice_Optimistic rule, since we don't want to disturb the
750 -- elaboration rules of the language with -p; same treatment for
753 -- Prefer a predefined unit to a non-predefined unit
755 if UT1.Predefined and then not UT2.Predefined then
757 Write_Line (" True: u1 is predefined, u2 is not");
762 elsif UT2.Predefined and then not UT1.Predefined then
764 Write_Line (" False: u2 is predefined, u1 is not");
769 -- Prefer an internal unit to a non-internal unit
771 elsif UT1.Internal and then not UT2.Internal then
773 Write_Line (" True: u1 is internal, u2 is not");
778 elsif UT2.Internal and then not UT1.Internal then
780 Write_Line (" False: u2 is internal, u1 is not");
785 -- Prefer a pure or preelaborated unit to one that is not
787 elsif Is_Pure_Or_Preelab_Unit (U1)
789 Is_Pure_Or_Preelab_Unit (U2)
792 Write_Line (" True: u1 is pure/preelab, u2 is not");
797 elsif Is_Pure_Or_Preelab_Unit (U2)
799 Is_Pure_Or_Preelab_Unit (U1)
802 Write_Line (" False: u2 is pure/preelab, u1 is not");
807 -- Prefer anything else to a waiting body. We want to make bodies wait
808 -- as long as possible, till we are forced to choose them.
810 elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
812 Write_Line (" False: u1 is waiting body, u2 is not");
817 elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
819 Write_Line (" True: u2 is waiting body, u1 is not");
824 -- Prefer a spec to a body (this is mandatory)
826 elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
828 Write_Line (" False: u1 is body, u2 is not");
833 elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
835 Write_Line (" True: u2 is body, u1 is not");
840 -- If both are waiting bodies, then prefer the one whose spec is less
841 -- recently elaborated. Consider the following:
847 -- The normal waiting body preference would have placed the body of A
848 -- before the spec of B if it could. Since it could not, then it must be
849 -- the case that A depends on B. It is therefore a good idea to put the
850 -- body of B last so that if there is an elaboration order problem, we
851 -- will find it (that's what pessimistic order is about).
853 elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
855 Result : constant Boolean :=
856 UNR.Table (Corresponding_Spec (U1)).Elab_Position <
857 UNR.Table (Corresponding_Spec (U2)).Elab_Position;
861 Write_Line (" True: based on waiting body elab positions");
863 Write_Line (" False: based on waiting body elab positions");
871 -- Remaining choice rules are disabled by Debug flag -do
873 if not Debug_Flag_Older then
875 -- The following deal with the case of specs that have been marked as
876 -- Elaborate_Body_Desirable. In the normal case, we generally want to
877 -- delay the elaboration of these specs as long as possible, so that
878 -- bodies have better chance of being elaborated closer to the specs.
879 -- Better_Choice_Pessimistic as usual wants to do the opposite and
880 -- elaborate such specs as early as possible.
882 -- If we have two units, one of which is a spec for which this flag
883 -- is set, and the other is not, we normally prefer to delay the spec
884 -- for which the flag is set, so again Better_Choice_Pessimistic does
887 if not UT1.Elaborate_Body_Desirable
888 and then UT2.Elaborate_Body_Desirable
891 Write_Line (" False: u1 is elab body desirable, u2 is not");
896 elsif not UT2.Elaborate_Body_Desirable
897 and then UT1.Elaborate_Body_Desirable
900 Write_Line (" True: u1 is elab body desirable, u2 is not");
905 -- If we have two specs that are both marked as Elaborate_Body
906 -- desirable, we normally prefer the one whose body is nearer to
907 -- being able to be elaborated, based on the Num_Pred count. This
908 -- helps to ensure bodies are as close to specs as possible. As
909 -- usual, Better_Choice_Pessimistic does the opposite.
911 elsif UT1.Elaborate_Body_Desirable
912 and then UT2.Elaborate_Body_Desirable
915 Result : constant Boolean :=
916 UNR.Table (Corresponding_Body (U1)).Num_Pred >=
917 UNR.Table (Corresponding_Body (U2)).Num_Pred;
921 Write_Line (" True based on Num_Pred compare");
923 Write_Line (" False based on Num_Pred compare");
932 -- If we fall through, it means that no preference rule applies, so we
933 -- use alphabetical order to at least give a deterministic result. Since
934 -- Better_Choice_Pessimistic is in the business of stirring up the
935 -- order, we will use reverse alphabetical ordering.
938 Write_Line (" choose on reverse alpha order");
941 return Uname_Less (UT2.Uname, UT1.Uname);
942 end Better_Choice_Pessimistic;
952 Ea_Id : Elab_All_Id := No_Elab_All_Link)
959 After => No_Unit_Id, -- filled in below
960 Next => UNR.Table (Before).Successors,
962 Elab_Body => False, -- set correctly below
963 Reason_Unit => Cur_Unit,
964 Elab_All_Link => Ea_Id));
965 UNR.Table (Before).Successors := Succ.Last;
967 -- Deal with special Elab_Body case. If the After of this link is
968 -- a body whose spec has Elaborate_All set, and this is not the link
969 -- directly from the body to the spec, then we make the After of the
970 -- link reference its spec instead, marking the link appropriately.
972 if Units.Table (After).Utype = Is_Body then
973 Cspec := Corresponding_Spec (After);
975 if Units.Table (Cspec).Elaborate_Body
976 and then Cspec /= Before
978 Succ.Table (Succ.Last).After := Cspec;
979 Succ.Table (Succ.Last).Elab_Body := True;
980 UNR.Table (Cspec).Num_Pred := UNR.Table (Cspec).Num_Pred + 1;
985 -- Fall through on normal case
987 Succ.Table (Succ.Last).After := After;
988 Succ.Table (Succ.Last).Elab_Body := False;
989 UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1;
997 (Elab_Order : in out Unit_Id_Table;
1001 pragma Assert (Chosen /= No_Unit_Id);
1006 if Debug_Flag_C then
1007 Write_Str ("Choosing Unit ");
1008 Write_Unit_Name (Units.Table (Chosen).Uname);
1012 -- We shouldn't be choosing something with unelaborated predecessors,
1013 -- and we shouldn't call this twice on the same unit. But that's not
1014 -- true when this is called from Diagnose_Elaboration_Problem.
1016 if Errors_Detected = 0 then
1017 pragma Assert (UNR.Table (Chosen).Num_Pred = 0);
1018 pragma Assert (UNR.Table (Chosen).Elab_Position = 0);
1019 pragma Assert (not Doing_New or else SCC_Num_Pred (Chosen) = 0);
1023 -- Add to elaboration order. Note that units having no elaboration code
1024 -- are not treated specially yet. The special casing of this is in
1025 -- Bindgen, where Gen_Elab_Calls skips over them. Meanwhile we need them
1026 -- here, because the object file list is also driven by the contents of
1027 -- the Elab_Order table.
1029 Append (Elab_Order, Chosen);
1031 -- Remove from No_Pred list. This is a little inefficient and may be we
1032 -- should doubly link the list, but it will do for now.
1034 if No_Pred = Chosen then
1035 No_Pred := UNR.Table (Chosen).Nextnp;
1038 while U /= No_Unit_Id loop
1039 if UNR.Table (U).Nextnp = Chosen then
1040 UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp;
1044 U := UNR.Table (U).Nextnp;
1047 -- Here if we didn't find it on the No_Pred list. This can happen
1048 -- only in calls from the Diagnose_Elaboration_Problem routine,
1049 -- where cycles are being removed arbitrarily from the graph.
1051 pragma Assert (Errors_Detected > 0);
1052 <<Done_Removal>> null;
1055 -- For all successors, decrement the number of predecessors, and if it
1056 -- becomes zero, then add to no-predecessor list.
1058 S := UNR.Table (Chosen).Successors;
1059 pragma Annotate (CodePeer, Modified, S);
1061 while S /= No_Successor loop
1062 U := Succ.Table (S).After;
1063 UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1;
1065 if Debug_Flag_N then
1066 Write_Str (" decrementing Num_Pred for unit ");
1067 Write_Unit_Name (Units.Table (U).Uname);
1068 Write_Str (" new value = ");
1069 Write_Int (UNR.Table (U).Num_Pred);
1073 if UNR.Table (U).Num_Pred = 0 then
1074 UNR.Table (U).Nextnp := No_Pred;
1078 if Doing_New and then SCC (U) /= SCC (Chosen) then
1079 UNR.Table (SCC (U)).SCC_Num_Pred :=
1080 UNR.Table (SCC (U)).SCC_Num_Pred - 1;
1082 if Debug_Flag_N then
1083 Write_Str (" decrementing SCC_Num_Pred for unit ");
1084 Write_Unit_Name (Units.Table (U).Uname);
1085 Write_Str (" new value = ");
1086 Write_Int (SCC_Num_Pred (U));
1091 S := Succ.Table (S).Next;
1094 -- All done, adjust number of units left count and set elaboration pos
1096 Num_Left := Num_Left - 1;
1097 Num_Chosen := Num_Chosen + 1;
1100 (Errors_Detected > 0 or else Num_Chosen = Last (Elab_Order));
1101 pragma Assert (Units.Last = UNR.Last);
1102 pragma Assert (Num_Chosen + Num_Left = Int (UNR.Last));
1104 if Debug_Flag_C then
1106 Write_Int (Int (Num_Chosen));
1108 Write_Int (Num_Left);
1110 Write_Int (Int (UNR.Last));
1114 UNR.Table (Chosen).Elab_Position := Num_Chosen;
1116 -- If we just chose a spec with Elaborate_Body set, then we must
1117 -- immediately elaborate the body, before any other units.
1119 if Units.Table (Chosen).Elaborate_Body then
1121 -- If the unit is a spec only, then there is no body. This is a bit
1122 -- odd given that Elaborate_Body is here, but it is valid in an RCI
1123 -- unit, where we only have the interface in the stub bind.
1125 if Units.Table (Chosen).Utype = Is_Spec_Only
1126 and then Units.Table (Chosen).RCI
1130 -- If this unit is an interface to a stand-alone library, then we
1131 -- don't want to elaborate the body -- that will happen as part of
1134 elsif Units.Table (Chosen).SAL_Interface then
1139 (Elab_Order => Elab_Order,
1140 Chosen => Corresponding_Body (Chosen),
1141 Msg => " [Elaborate_Body]");
1146 ------------------------
1147 -- Corresponding_Body --
1148 ------------------------
1150 -- Currently if the body and spec are separate, then they appear as two
1151 -- separate units in the same ALI file, with the body appearing first and
1152 -- the spec appearing second.
1154 function Corresponding_Body (U : Unit_Id) return Unit_Id is
1156 pragma Assert (Units.Table (U).Utype = Is_Spec);
1158 end Corresponding_Body;
1160 ------------------------
1161 -- Corresponding_Spec --
1162 ------------------------
1164 -- Currently if the body and spec are separate, then they appear as two
1165 -- separate units in the same ALI file, with the body appearing first and
1166 -- the spec appearing second.
1168 function Corresponding_Spec (U : Unit_Id) return Unit_Id is
1170 pragma Assert (Units.Table (U).Utype = Is_Body);
1172 end Corresponding_Spec;
1174 --------------------
1175 -- Debug_Flag_Old --
1176 --------------------
1178 function Debug_Flag_Old return Boolean is
1180 -- If the user specified both flags, we want to use the older algorithm,
1181 -- rather than some confusing mix of the two.
1183 return Debug_Flag_P and not Debug_Flag_O;
1186 ----------------------
1187 -- Debug_Flag_Older --
1188 ----------------------
1190 function Debug_Flag_Older return Boolean is
1192 return Debug_Flag_O;
1193 end Debug_Flag_Older;
1195 ----------------------------------
1196 -- Diagnose_Elaboration_Problem --
1197 ----------------------------------
1199 procedure Diagnose_Elaboration_Problem
1200 (Elab_Order : in out Unit_Id_Table)
1205 ML : Nat) return Boolean;
1206 -- Recursive routine used to find a path from node Ufrom to node Uto.
1207 -- If a path exists, returns True and outputs an appropriate set of
1208 -- error messages giving the path. Also calls Choose for each of the
1209 -- nodes so that they get removed from the remaining set. There are
1210 -- two cases of calls, either Ufrom = Uto for an attempt to find a
1211 -- cycle, or Ufrom is a spec and Uto the corresponding body for the
1212 -- case of an unsatisfiable Elaborate_Body pragma. ML is the minimum
1213 -- acceptable length for a path.
1222 ML : Nat) return Boolean
1224 function Find_Link (U : Unit_Id; PL : Nat) return Boolean;
1225 -- This is the inner recursive routine, it determines if a path
1226 -- exists from U to Uto, and if so returns True and outputs the
1227 -- appropriate set of error messages. PL is the path length
1233 function Find_Link (U : Unit_Id; PL : Nat) return Boolean is
1237 -- Recursion ends if we are at terminating node and the path is
1238 -- sufficiently long, generate error message and return True.
1240 if U = Uto and then PL >= ML then
1241 Choose (Elab_Order, U, " [Find_Link: base]");
1244 -- All done if already visited
1246 elsif UNR.Table (U).Visited then
1249 -- Otherwise mark as visited and look at all successors
1252 UNR.Table (U).Visited := True;
1254 S := UNR.Table (U).Successors;
1255 while S /= No_Successor loop
1256 if Find_Link (Succ.Table (S).After, PL + 1) then
1258 Choose (Elab_Order, U, " [Find_Link: recursive]");
1262 S := Succ.Table (S).Next;
1265 -- Falling through means this does not lead to a path
1271 -- Start of processing for Find_Path
1274 -- Initialize all non-chosen nodes to not visited yet
1276 for U in Units.First .. Units.Last loop
1277 UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0;
1280 -- Now try to find the path
1282 return Find_Link (Ufrom, 0);
1285 -- Start of processing for Diagnose_Elaboration_Problem
1288 Diagnose_Elaboration_Problem_Called := True;
1291 -- Output state of things if debug flag N set
1293 if Debug_Flag_N then
1300 Write_Line ("Diagnose_Elaboration_Problem called");
1301 Write_Line ("List of remaining unchosen units and predecessors");
1303 for U in Units.First .. Units.Last loop
1304 if UNR.Table (U).Elab_Position = 0 then
1305 NP := UNR.Table (U).Num_Pred;
1307 Write_Str (" Unchosen unit: #");
1308 Write_Int (Int (U));
1310 Write_Unit_Name (Units.Table (U).Uname);
1311 Write_Str (" (Num_Pred = ");
1316 if Units.Table (U).Elaborate_Body then
1318 (" (not chosen because of Elaborate_Body)");
1320 Write_Line (" ****************** why not chosen?");
1324 -- Search links list to find unchosen predecessors
1326 for S in Succ.First .. Succ.Last loop
1328 SL : Successor_Link renames Succ.Table (S);
1332 and then UNR.Table (SL.Before).Elab_Position = 0
1334 Write_Str (" unchosen predecessor: #");
1335 Write_Int (Int (SL.Before));
1337 Write_Unit_Name (Units.Table (SL.Before).Uname);
1345 Write_Line (" **************** Num_Pred value wrong!");
1352 -- Output the header for the error, and manually increment the error
1353 -- count. We are using Error_Msg_Output rather than Error_Msg here for
1356 -- This is really only one error, not one for each line
1357 -- We want this output on standard output since it is voluminous
1359 -- But we do need to deal with the error count manually in this case
1361 Errors_Detected := Errors_Detected + 1;
1362 Error_Msg_Output ("elaboration circularity detected", Info => False);
1364 -- Try to find cycles starting with any of the remaining nodes that have
1365 -- not yet been chosen. There must be at least one (there is some reason
1366 -- we are being called).
1368 for U in Units.First .. Units.Last loop
1369 if UNR.Table (U).Elab_Position = 0 then
1370 if Find_Path (U, U, 1) then
1371 raise Unrecoverable_Error;
1376 -- We should never get here, since we were called for some reason, and
1377 -- we should have found and eliminated at least one bad path.
1379 raise Program_Error;
1380 end Diagnose_Elaboration_Problem;
1382 --------------------
1383 -- Elab_All_Links --
1384 --------------------
1386 procedure Elab_All_Links
1389 Reason : Succ_Reason;
1393 if UNR.Table (Before).Visited then
1397 -- Build the direct link for Before
1399 UNR.Table (Before).Visited := True;
1400 Build_Link (Before, After, Reason, Link);
1402 -- Process all units with'ed by Before recursively
1404 for W in Units.Table (Before).First_With ..
1405 Units.Table (Before).Last_With
1407 -- Skip if this with is an interface to a stand-alone library. Skip
1408 -- also if no ALI file for this WITH, happens for language defined
1409 -- generics while bootstrapping the compiler (see body of routine
1410 -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited with
1411 -- clause, which does not impose an elaboration link.
1413 if not Withs.Table (W).SAL_Interface
1414 and then Withs.Table (W).Afile /= No_File
1415 and then not Withs.Table (W).Limited_With
1418 Info : constant Int :=
1419 Get_Name_Table_Int (Withs.Table (W).Uname);
1422 -- If the unit is unknown, for some unknown reason, fail
1423 -- graciously explaining that the unit is unknown. Without
1424 -- this check, gnatbind will crash in Unit_Id_Of.
1426 if Info = 0 or else Unit_Id (Info) = No_Unit_Id then
1429 Get_Name_String (Withs.Table (W).Uname);
1430 Last_Withed : Natural := Withed'Last;
1433 (Units.Table (Before).Uname);
1434 Last_Withing : Natural := Withing'Last;
1435 Spec_Body : String := " (Spec)";
1442 and then Withed (Last_Withed - 1) = '%'
1444 Last_Withed := Last_Withed - 2;
1448 and then Withing (Last_Withing - 1) = '%'
1450 Last_Withing := Last_Withing - 2;
1453 if Units.Table (Before).Utype = Is_Body
1454 or else Units.Table (Before).Utype = Is_Body_Only
1456 Spec_Body := " (Body)";
1460 ("could not find unit "
1461 & Withed (Withed'First .. Last_Withed) & " needed by "
1462 & Withing (Withing'First .. Last_Withing) & Spec_Body);
1467 (Unit_Id_Of (Withs.Table (W).Uname),
1470 Make_Elab_All_Entry (Withs.Table (W).Uname, Link));
1475 -- Process corresponding body, if there is one
1477 if Units.Table (Before).Utype = Is_Spec then
1479 (Corresponding_Body (Before),
1482 (Units.Table (Corresponding_Body (Before)).Uname, Link));
1486 --------------------
1487 -- Elab_Error_Msg --
1488 --------------------
1490 procedure Elab_Error_Msg (S : Successor_Id) is
1491 SL : Successor_Link renames Succ.Table (S);
1494 -- Nothing to do if internal unit involved and no -da flag
1498 (Is_Internal_File_Name (Units.Table (SL.Before).Sfile)
1500 Is_Internal_File_Name (Units.Table (SL.After).Sfile))
1505 -- Here we want to generate output
1507 Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
1509 if SL.Elab_Body then
1510 Error_Msg_Unit_2 := Units.Table (Corresponding_Body (SL.After)).Uname;
1512 Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
1515 Error_Msg_Output (" $ must be elaborated before $", Info => True);
1517 Error_Msg_Unit_1 := Units.Table (SL.Reason_Unit).Uname;
1522 (" reason: with clause",
1527 (" reason: forced by -f switch",
1532 (" reason: pragma Elaborate in unit $",
1537 (" reason: pragma Elaborate_All in unit $",
1540 when Elab_All_Desirable =>
1542 (" reason: implicit Elaborate_All in unit $",
1546 (" recompile $ with -gnatel for full details",
1549 when Elab_Desirable =>
1551 (" reason: implicit Elaborate in unit $",
1555 (" recompile $ with -gnatel for full details",
1560 (" reason: spec always elaborated before body",
1564 Write_Elab_All_Chain (S);
1566 if SL.Elab_Body then
1567 Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
1568 Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
1570 (" $ must therefore be elaborated before $", True);
1572 Error_Msg_Unit_1 := Units.Table (SL.After).Uname;
1574 (" (because $ has a pragma Elaborate_Body)", True);
1577 if not Zero_Formatting then
1582 ---------------------
1583 -- Find_Elab_Order --
1584 ---------------------
1586 procedure Find_Elab_Order
1587 (Elab_Order : out Unit_Id_Table;
1588 First_Main_Lib_File : File_Name_Type)
1590 function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat;
1591 -- Number of cases where the body of a unit immediately follows the
1592 -- corresponding spec. Such cases are good, because calls to that unit
1593 -- from outside can't get ABE.
1595 -------------------------
1596 -- Num_Spec_Body_Pairs --
1597 -------------------------
1599 function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat is
1603 for J in Order'First + 1 .. Order'Last loop
1604 if Units.Table (Order (J - 1)).Utype = Is_Spec
1605 and then Units.Table (Order (J)).Utype = Is_Body
1606 and then Corresponding_Spec (Order (J)) = Order (J - 1)
1608 Result := Result + 1;
1613 end Num_Spec_Body_Pairs;
1617 Old_Elab_Order : Unit_Id_Table;
1619 -- Start of processing for Find_Elab_Order
1622 -- Output warning if -p used with no -gnatE units
1624 if Pessimistic_Elab_Order
1625 and not Dynamic_Elaboration_Checks_Specified
1627 Error_Msg ("?use of -p switch questionable");
1628 Error_Msg ("?since all units compiled with static elaboration model");
1631 if Do_New and not Debug_Flag_Old and not Debug_Flag_Older then
1632 if Debug_Flag_V then
1633 Write_Line ("Doing new...");
1638 Elab_New.Find_Elab_Order (Elab_Order);
1641 -- Elab_New does not support the pessimistic order, so if that was
1642 -- requested, use the old results. Use Elab_Old if -dp or -do was
1643 -- selected. Elab_New does not yet give proper error messages for
1644 -- illegal Elaborate_Alls, so if there is one, run Elab_Old.
1647 or Pessimistic_Elab_Order
1652 if Debug_Flag_V then
1653 Write_Line ("Doing old...");
1658 Elab_Old.Find_Elab_Order (Old_Elab_Order);
1661 pragma Assert (Elab_Cycle_Found <= -- implies
1662 Diagnose_Elaboration_Problem_Called);
1665 Old_Order : Unit_Id_Array renames
1666 Old_Elab_Order.Table (1 .. Last (Old_Elab_Order));
1668 if Do_Old and Do_New then
1670 New_Order : Unit_Id_Array renames
1671 Elab_Order.Table (1 .. Last (Elab_Order));
1672 Old_Pairs : constant Nat := Num_Spec_Body_Pairs (Old_Order);
1673 New_Pairs : constant Nat := Num_Spec_Body_Pairs (New_Order);
1676 Write_Line (Get_Name_String (First_Main_Lib_File));
1678 pragma Assert (Old_Order'Length = New_Order'Length);
1679 pragma Debug (Validate (Old_Order, Doing_New => False));
1680 pragma Debug (Validate (New_Order, Doing_New => True));
1682 -- Misc debug printouts that can be used for experimentation by
1683 -- changing the 'if's below.
1686 if New_Order = Old_Order then
1687 Write_Line ("Elab_New: same order.");
1689 Write_Line ("Elab_New: diff order.");
1693 if New_Order /= Old_Order and then False then
1694 Write_Line ("Elaboration orders differ:");
1696 (Old_Order, Title => "OLD ELABORATION ORDER");
1698 (New_Order, Title => "NEW ELABORATION ORDER");
1702 Write_Str ("Pairs: ");
1703 Write_Int (Old_Pairs);
1705 if Old_Pairs = New_Pairs then
1707 elsif Old_Pairs < New_Pairs then
1713 Write_Int (New_Pairs);
1717 if Old_Pairs /= New_Pairs and then False then
1718 Write_Str ("Pairs: ");
1719 Write_Int (Old_Pairs);
1721 if Old_Pairs < New_Pairs then
1727 Write_Int (New_Pairs);
1730 if Old_Pairs /= New_Pairs and then Debug_Flag_V then
1732 (Old_Order, Title => "OLD ELABORATION ORDER");
1734 (New_Order, Title => "NEW ELABORATION ORDER");
1735 pragma Assert (New_Pairs >= Old_Pairs);
1741 -- The Elab_New algorithm doesn't implement the -p switch, so if that
1742 -- was used, use the results from the old algorithm. Likewise if the
1743 -- user has requested the old algorithm.
1745 if Pessimistic_Elab_Order or Debug_Flag_Old or Debug_Flag_Older then
1747 (Last (Elab_Order) = 0
1748 or else Last (Elab_Order) = Old_Order'Last);
1751 Append_All (Elab_Order, Old_Order);
1754 -- Now set the Elab_Positions in the Units table. It is important to
1755 -- do this late, in case we're running both Elab_New and Elab_Old.
1758 New_Order : Unit_Id_Array renames
1759 Elab_Order.Table (1 .. Last (Elab_Order));
1760 Units_Array : Units.Table_Type renames
1761 Units.Table (Units.First .. Units.Last);
1763 for J in New_Order'Range loop
1765 (UNR.Table (New_Order (J)).Elab_Position = J);
1766 Units_Array (New_Order (J)).Elab_Position := J;
1769 if Errors_Detected = 0 then
1771 -- Display elaboration order if -l was specified
1773 if Elab_Order_Output then
1774 if Zero_Formatting then
1775 Write_Elab_Order (New_Order, Title => "");
1778 (New_Order, Title => "ELABORATION ORDER");
1782 -- Display list of sources in the closure (except predefined
1783 -- sources) if -R was used. Include predefined sources if -Ra
1786 if List_Closure then
1787 Write_Closure (New_Order);
1792 end Find_Elab_Order;
1794 ----------------------
1795 -- Force_Elab_Order --
1796 ----------------------
1798 procedure Force_Elab_Order is
1799 subtype Header_Num is Unit_Name_Type'Base range 0 .. 2**16 - 1;
1801 function Hash (N : Unit_Name_Type) return Header_Num;
1803 package Name_Map is new System.HTable.Simple_HTable
1804 (Header_Num => Header_Num,
1805 Element => Logical_Line_Number,
1806 No_Element => No_Line_Number,
1807 Key => Unit_Name_Type,
1810 -- Name_Map contains an entry for each file name seen, mapped to the
1811 -- line number where we saw it first. This is used to give an error for
1818 function Hash (N : Unit_Name_Type) return Header_Num is
1819 -- Name_Ids are already widely dispersed; no need for any actual
1820 -- hashing. Just subtract to make it zero based, and "mod" to
1821 -- bring it in range.
1823 return (N - Unit_Name_Type'First) mod (Header_Num'Last + 1);
1828 Cur_Line_Number : Logical_Line_Number;
1829 Error : Boolean := False;
1830 Iter : Forced_Units_Iterator;
1831 Prev_Unit : Unit_Id := No_Unit_Id;
1832 Uname : Unit_Name_Type;
1834 -- Start of processing for Force_Elab_Order
1837 Iter := Iterate_Forced_Units;
1838 while Has_Next (Iter) loop
1839 Next (Iter, Uname, Cur_Line_Number);
1842 Dup : constant Logical_Line_Number := Name_Map.Get (Uname);
1844 if Dup = No_Line_Number then
1845 Name_Map.Set (Uname, Cur_Line_Number);
1847 -- We don't need to give the "not present" message in the case
1848 -- of "duplicate unit", because we would have already given the
1849 -- "not present" message on the first occurrence.
1851 if Get_Name_Table_Int (Uname) = 0
1852 or else Unit_Id (Get_Name_Table_Int (Uname)) = No_Unit_Id
1857 ("""" & Get_Name_String (Uname)
1858 & """: not present; ignored");
1865 Error_Msg_Nat_1 := Nat (Cur_Line_Number);
1866 Error_Msg_Unit_1 := Uname;
1867 Error_Msg_Nat_2 := Nat (Dup);
1869 (Force_Elab_Order_File.all
1870 & ":#: duplicate unit name $ from line #");
1877 Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname);
1879 if Is_Internal_File_Name (Units.Table (Cur_Unit).Sfile) then
1882 ("""" & Get_Name_String (Uname)
1883 & """: predefined unit ignored");
1887 if Prev_Unit /= No_Unit_Id then
1889 Write_Unit_Name (Units.Table (Prev_Unit).Uname);
1890 Write_Str (" <-- ");
1891 Write_Unit_Name (Units.Table (Cur_Unit).Uname);
1896 (Before => Prev_Unit,
1901 Prev_Unit := Cur_Unit;
1906 end Force_Elab_Order;
1908 -------------------------
1909 -- Gather_Dependencies --
1910 -------------------------
1912 procedure Gather_Dependencies is
1913 Withed_Unit : Unit_Id;
1916 -- Loop through all units
1918 for U in Units.First .. Units.Last loop
1921 -- If this is not an interface to a stand-alone library and there is
1922 -- a body and a spec, then spec must be elaborated first. Note that
1923 -- the corresponding spec immediately follows the body.
1925 if not Units.Table (U).SAL_Interface
1926 and then Units.Table (U).Utype = Is_Body
1928 Build_Link (Corresponding_Spec (U), U, Spec_First);
1931 -- If this unit is not an interface to a stand-alone library, process
1932 -- WITH references for this unit ignoring interfaces to stand-alone
1935 if not Units.Table (U).SAL_Interface then
1936 for W in Units.Table (U).First_With ..
1937 Units.Table (U).Last_With
1939 if Withs.Table (W).Sfile /= No_File
1940 and then (not Withs.Table (W).SAL_Interface)
1942 -- Check for special case of withing a unit that does not
1943 -- exist any more. If the unit was completely missing we
1944 -- would already have detected this, but a nasty case arises
1945 -- when we have a subprogram body with no spec, and some
1946 -- obsolete unit with's a previous (now disappeared) spec.
1948 if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then
1950 Error_Msg_File_1 := Units.Table (U).Sfile;
1951 Error_Msg_Unit_1 := Withs.Table (W).Uname;
1952 Error_Msg ("{ depends on $ which no longer exists");
1958 Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname);
1960 -- Pragma Elaborate_All case, for this we use the recursive
1961 -- Elab_All_Links procedure to establish the links.
1963 -- Elab_New ignores Elaborate_All and Elab_All_Desirable,
1964 -- except for error messages.
1966 if Withs.Table (W).Elaborate_All and then not Doing_New then
1968 -- Reset flags used to stop multiple visits to a given
1971 for Uref in UNR.First .. UNR.Last loop
1972 UNR.Table (Uref).Visited := False;
1975 -- Now establish all the links we need
1978 (Withed_Unit, U, Elab_All,
1980 (Withs.Table (W).Uname, No_Elab_All_Link));
1982 -- Elaborate_All_Desirable case, for this we establish the
1983 -- same links as above, but with a different reason.
1985 elsif Withs.Table (W).Elab_All_Desirable
1986 and then not Doing_New
1988 -- Reset flags used to stop multiple visits to a given
1991 for Uref in UNR.First .. UNR.Last loop
1992 UNR.Table (Uref).Visited := False;
1995 -- Now establish all the links we need
1998 (Withed_Unit, U, Elab_All_Desirable,
2000 (Withs.Table (W).Uname, No_Elab_All_Link));
2002 -- Pragma Elaborate case. We must build a link for the
2003 -- withed unit itself, and also the corresponding body if
2006 -- However, skip this processing if there is no ALI file for
2007 -- the WITH entry, because this means it is a generic (even
2008 -- when we fix the generics so that an ALI file is present,
2009 -- we probably still will have no ALI file for unchecked and
2010 -- other special cases).
2012 elsif Withs.Table (W).Elaborate
2013 and then Withs.Table (W).Afile /= No_File
2015 Build_Link (Withed_Unit, U, Withed);
2017 if Units.Table (Withed_Unit).Utype = Is_Spec then
2019 (Corresponding_Body (Withed_Unit), U, Elab);
2022 -- Elaborate_Desirable case, for this we establish the same
2023 -- links as above, but with a different reason.
2025 elsif Withs.Table (W).Elab_Desirable then
2026 Build_Link (Withed_Unit, U, Withed);
2028 if Units.Table (Withed_Unit).Utype = Is_Spec then
2030 (Corresponding_Body (Withed_Unit),
2034 -- A limited_with does not establish an elaboration
2035 -- dependence (that's the whole point).
2037 elsif Withs.Table (W).Limited_With then
2040 -- Case of normal WITH with no elaboration pragmas, just
2041 -- build the single link to the directly referenced unit
2044 Build_Link (Withed_Unit, U, Withed);
2054 -- If -f<elab_order> switch was given, take into account dependences
2055 -- specified in the file <elab_order>.
2057 if Force_Elab_Order_File /= null then
2061 -- Output elaboration dependencies if option is set
2063 if Elab_Dependency_Output or Debug_Flag_E then
2068 end Gather_Dependencies;
2077 Num_Left := Int (Units.Last - Units.First + 1);
2079 Elab_All_Entries.Init;
2082 -- Initialize unit table for elaboration control
2084 for U in Units.First .. Units.Last loop
2086 ((Successors => No_Successor,
2088 Nextnp => No_Unit_Id,
2091 SCC_Root => No_Unit_Id,
2094 Validate_Seen => False));
2102 function Is_Body_Unit (U : Unit_Id) return Boolean is
2105 Units.Table (U).Utype = Is_Body
2106 or else Units.Table (U).Utype = Is_Body_Only;
2109 -----------------------------
2110 -- Is_Pure_Or_Preelab_Unit --
2111 -----------------------------
2113 function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean is
2115 -- If we have a body with separate spec, test flags on the spec
2117 if Units.Table (U).Utype = Is_Body then
2119 Units.Table (Corresponding_Spec (U)).Preelab
2120 or else Units.Table (Corresponding_Spec (U)).Pure;
2122 -- Otherwise we have a spec or body acting as spec, test flags on unit
2125 return Units.Table (U).Preelab or else Units.Table (U).Pure;
2127 end Is_Pure_Or_Preelab_Unit;
2129 ---------------------
2130 -- Is_Waiting_Body --
2131 ---------------------
2133 function Is_Waiting_Body (U : Unit_Id) return Boolean is
2136 Units.Table (U).Utype = Is_Body
2137 and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
2138 end Is_Waiting_Body;
2140 -------------------------
2141 -- Make_Elab_All_Entry --
2142 -------------------------
2144 function Make_Elab_All_Entry
2145 (Unam : Unit_Name_Type;
2146 Link : Elab_All_Id) return Elab_All_Id
2149 Elab_All_Entries.Append ((Needed_By => Unam, Next_Elab => Link));
2150 return Elab_All_Entries.Last;
2151 end Make_Elab_All_Entry;
2157 function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
2158 Info : constant Int := Get_Name_Table_Int (Uname);
2161 pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
2162 return Unit_Id (Info);
2169 procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean) is
2170 Cur_SCC : Unit_Id := No_Unit_Id;
2171 OK : Boolean := True;
2172 Msg : String := "Old: ";
2179 -- For each unit, assert that its successors are elaborated after it
2181 for J in Order'Range loop
2183 U : constant Unit_Id := Order (J);
2184 S : Successor_Id := UNR.Table (U).Successors;
2187 while S /= No_Successor loop
2188 if UNR.Table (Succ.Table (S).After).Elab_Position <=
2189 UNR.Table (U).Elab_Position
2192 Write_Line (Msg & " elab order failed");
2195 S := Succ.Table (S).Next;
2200 -- An SCC of size 2 units necessarily consists of a spec and the
2201 -- corresponding body. Assert that the body is elaborated immediately
2202 -- after the spec, with nothing in between. (We only have SCCs in the
2206 for J in Order'Range loop
2208 U : constant Unit_Id := Order (J);
2211 if Nodes (U)'Length = 2 then
2212 if Units.Table (U).Utype = Is_Spec then
2213 if Order (J + 1) /= Corresponding_Body (U) then
2215 Write_Line (Msg & "Bad spec with SCC of size 2:");
2216 Write_SCC (SCC (U));
2220 if Units.Table (U).Utype = Is_Body then
2221 if Order (J - 1) /= Corresponding_Spec (U) then
2223 Write_Line (Msg & "Bad body with SCC of size 2:");
2224 Write_SCC (SCC (U));
2231 -- Assert that all units of an SCC are elaborated together, with no
2232 -- units from other SCCs in between. The above spec/body case is a
2233 -- special case of this general rule.
2235 for J in Order'Range loop
2237 U : constant Unit_Id := Order (J);
2240 if SCC (U) /= Cur_SCC then
2242 if UNR.Table (Cur_SCC).Validate_Seen then
2244 Write_Line (Msg & "SCC not elaborated together:");
2245 Write_SCC (Cur_SCC);
2248 UNR.Table (Cur_SCC).Validate_Seen := True;
2261 procedure Write_Closure (Order : Unit_Id_Array) is
2262 package Closure_Sources is new Table.Table
2263 (Table_Component_Type => File_Name_Type,
2264 Table_Index_Type => Natural,
2265 Table_Low_Bound => 1,
2266 Table_Initial => 10,
2267 Table_Increment => 100,
2268 Table_Name => "Gnatbind.Closure_Sources");
2269 -- Table to record the sources in the closure, to avoid duplications
2271 function Put_In_Sources (S : File_Name_Type) return Boolean;
2272 -- Check if S is already in table Sources and put in Sources if it is
2273 -- not. Return False if the source is already in Sources, and True if
2276 --------------------
2277 -- Put_In_Sources --
2278 --------------------
2280 function Put_In_Sources (S : File_Name_Type) return Boolean is
2282 for J in 1 .. Closure_Sources.Last loop
2283 if Closure_Sources.Table (J) = S then
2288 Closure_Sources.Append (S);
2294 Source : File_Name_Type;
2296 -- Start of processing for Write_Closure
2299 Closure_Sources.Init;
2301 if not Zero_Formatting then
2303 Write_Line ("REFERENCED SOURCES");
2306 for J in reverse Order'Range loop
2307 Source := Units.Table (Order (J)).Sfile;
2309 -- Do not include same source more than once
2311 if Put_In_Sources (Source)
2313 -- Do not include run-time units unless -Ra switch set
2315 and then (List_Closure_All
2316 or else not Is_Internal_File_Name (Source))
2318 if not Zero_Formatting then
2322 Write_Line (Get_Name_String (Source));
2326 -- Subunits do not appear in the elaboration table because they are
2327 -- subsumed by their parent units, but we need to list them for other
2328 -- tools. For now they are listed after other files, rather than right
2329 -- after their parent, since there is no easy link between the
2330 -- elaboration table and the ALIs table ??? As subunits may appear
2331 -- repeatedly in the list, if the parent unit appears in the context of
2332 -- several units in the closure, duplicates are suppressed.
2334 for J in Sdep.First .. Sdep.Last loop
2335 Source := Sdep.Table (J).Sfile;
2337 if Sdep.Table (J).Subunit_Name /= No_Name
2338 and then Put_In_Sources (Source)
2339 and then not Is_Internal_File_Name (Source)
2341 if not Zero_Formatting then
2345 Write_Line (Get_Name_String (Source));
2349 if not Zero_Formatting then
2354 ------------------------
2355 -- Write_Dependencies --
2356 ------------------------
2358 procedure Write_Dependencies is
2360 if not Zero_Formatting then
2362 Write_Line (" ELABORATION ORDER DEPENDENCIES");
2366 Info_Prefix_Suppress := True;
2368 for S in Succ_First .. Succ.Last loop
2372 Info_Prefix_Suppress := False;
2374 if not Zero_Formatting then
2377 end Write_Dependencies;
2379 --------------------------
2380 -- Write_Elab_All_Chain --
2381 --------------------------
2383 procedure Write_Elab_All_Chain (S : Successor_Id) is
2384 ST : constant Successor_Link := Succ.Table (S);
2385 After : constant Unit_Name_Type := Units.Table (ST.After).Uname;
2388 Nam : Unit_Name_Type;
2390 First_Name : Boolean := True;
2393 if ST.Reason in Elab_All .. Elab_All_Desirable then
2394 L := ST.Elab_All_Link;
2395 pragma Annotate (CodePeer, Modified, L);
2397 while L /= No_Elab_All_Link loop
2398 Nam := Elab_All_Entries.Table (L).Needed_By;
2399 Error_Msg_Unit_1 := Nam;
2400 Error_Msg_Output (" $", Info => True);
2402 Get_Name_String (Nam);
2404 if Name_Buffer (Name_Len) = 'b' then
2407 (" must be elaborated along with its spec:",
2412 (" which must be elaborated along with its "
2425 (" which is withed by:",
2430 First_Name := False;
2432 L := Elab_All_Entries.Table (L).Next_Elab;
2435 Error_Msg_Unit_1 := After;
2436 Error_Msg_Output (" $", Info => True);
2438 end Write_Elab_All_Chain;
2440 ----------------------
2441 -- Write_Elab_Order --
2442 ----------------------
2444 procedure Write_Elab_Order
2445 (Order : Unit_Id_Array; Title : String)
2453 for J in Order'Range loop
2454 if not Units.Table (Order (J)).SAL_Interface then
2455 if not Zero_Formatting then
2459 Write_Unit_Name (Units.Table (Order (J)).Uname);
2467 end Write_Elab_Order;
2473 package body Elab_New is
2479 type Node_Array is array (Pos range <>) of Node;
2480 with function Successors (N : Node) return Node_Array;
2481 with procedure Create_SCC (Root : Node; Nodes : Node_Array);
2483 procedure Compute_Strongly_Connected_Components;
2484 -- Compute SCCs for a directed graph. The nodes in the graph are all
2485 -- values of type Node in the range First_Node .. Last_Node.
2486 -- Successors(N) returns the nodes pointed to by the edges emanating
2487 -- from N. Create_SCC is a callback that is called once for each SCC,
2488 -- passing in the Root node for that SCC (which is an arbitrary node in
2489 -- the SCC used as a representative of that SCC), and the set of Nodes
2492 -- This is generic, in case we want to use it elsewhere; then we could
2493 -- move this into a separate library unit. Unfortunately, it's not as
2494 -- generic as one might like. Ideally, we would have "type Node is
2495 -- private;", and pass in iterators to iterate over all nodes, and over
2496 -- the successors of a given node. However, that leads to using advanced
2497 -- features of Ada that are not allowed in the compiler and binder for
2498 -- bootstrapping reasons. It also leads to trampolines, which are not
2499 -- allowed in the compiler and binder. Restricting Node to be discrete
2500 -- allows us to iterate over all nodes with a 'for' loop, and allows us
2501 -- to attach temporary information to nodes by having an array indexed
2504 procedure Compute_Unit_SCCs;
2505 -- Use the above generic procedure to compute the SCCs for the graph of
2506 -- units. Store in each Unit_Node_Record the SCC_Root and Nodes
2507 -- components. Also initialize the SCC_Num_Pred components.
2509 procedure Find_Elab_All_Errors;
2510 -- Generate an error for illegal Elaborate_All pragmas (explicit or
2511 -- implicit). A pragma Elaborate_All (Y) on unit X is legal if and only
2512 -- if X and Y are in different SCCs.
2514 -------------------------------------------
2515 -- Compute_Strongly_Connected_Components --
2516 -------------------------------------------
2518 procedure Compute_Strongly_Connected_Components is
2520 -- This uses Tarjan's algorithm for finding SCCs. Comments here are
2521 -- intended to tell what it does, but if you want to know how it
2522 -- works, you have to look it up. Please do not modify this code
2523 -- without reading up on Tarjan's algorithm.
2525 subtype Node_Index is Nat;
2526 No_Index : constant Node_Index := 0;
2528 Num_Nodes : constant Nat :=
2529 Node'Pos (Last_Node) - Node'Pos (First_Node) + 1;
2530 Stack : Node_Array (1 .. Num_Nodes);
2531 Top : Node_Index := 0;
2532 -- Stack of nodes, pushed when first visited. All nodes of an SCC are
2533 -- popped at once when the SCC is found.
2535 subtype Valid_Node is Node range First_Node .. Last_Node;
2536 Node_Indices : array (Valid_Node) of Node_Index :=
2537 (others => No_Index);
2538 -- Each node has an "index", which is the sequential number in the
2539 -- order in which they are visited in the recursive walk. No_Index
2540 -- means "not yet visited"; we want to avoid walking any node more
2543 Index : Node_Index := 1;
2544 -- Next value to be assigned to a node index
2546 Low_Links : array (Valid_Node) of Node_Index;
2547 -- Low_Links (N) is the smallest index of nodes reachable from N
2549 On_Stack : array (Valid_Node) of Boolean := (others => False);
2550 -- True if the node is currently on the stack
2552 procedure Walk (N : Valid_Node);
2553 -- Recursive depth-first graph walk, with the node index used to
2554 -- avoid visiting a node more than once.
2560 procedure Walk (N : Valid_Node) is
2561 Stack_Position_Of_N : constant Pos := Top + 1;
2562 S : constant Node_Array := Successors (N);
2565 -- Assign the index and low link, increment Index for next call to
2568 Node_Indices (N) := Index;
2569 Low_Links (N) := Index;
2572 -- Push it on the stack:
2574 Top := Stack_Position_Of_N;
2576 On_Stack (N) := True;
2578 -- Walk not-yet-visited subnodes, and update low link for visited
2579 -- ones as appropriate.
2581 for J in S'Range loop
2582 if Node_Indices (S (J)) = No_Index then
2585 Node_Index'Min (Low_Links (N), Low_Links (S (J)));
2586 elsif On_Stack (S (J)) then
2588 Node_Index'Min (Low_Links (N), Node_Indices (S (J)));
2592 -- If the index is (still) equal to the low link, we've found an
2593 -- SCC. Pop the whole SCC off the stack, and call Create_SCC.
2595 if Low_Links (N) = Node_Indices (N) then
2597 SCC : Node_Array renames
2598 Stack (Stack_Position_Of_N .. Top);
2599 pragma Assert (SCC'Length >= 1);
2600 pragma Assert (SCC (SCC'First) = N);
2603 for J in SCC'Range loop
2604 On_Stack (SCC (J)) := False;
2607 Create_SCC (Root => N, Nodes => SCC);
2608 pragma Assert (Top - SCC'Length = Stack_Position_Of_N - 1);
2609 Top := Stack_Position_Of_N - 1; -- pop all
2614 -- Start of processing for Compute_Strongly_Connected_Components
2617 -- Walk all the nodes that have not yet been walked
2619 for N in Valid_Node loop
2620 if Node_Indices (N) = No_Index then
2624 end Compute_Strongly_Connected_Components;
2626 -----------------------
2627 -- Compute_Unit_SCCs --
2628 -----------------------
2630 procedure Compute_Unit_SCCs is
2631 function Successors (U : Unit_Id) return Unit_Id_Array;
2632 -- Return all the units that must be elaborated after U. In addition,
2633 -- if U is a body, include the corresponding spec; this ensures that
2634 -- a spec/body pair are always in the same SCC.
2636 procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array);
2637 -- Set Nodes of the Root, and set SCC_Root of all the Nodes
2639 procedure Init_SCC_Num_Pred (U : Unit_Id);
2640 -- Initialize the SCC_Num_Pred fields, so that the root of each SCC
2641 -- has a count of the number of successors of all the units in the
2642 -- SCC, but only for successors outside the SCC.
2644 procedure Compute_SCCs is new Compute_Strongly_Connected_Components
2646 First_Node => Units.First,
2647 Last_Node => Units.Last,
2648 Node_Array => Unit_Id_Array,
2649 Successors => Successors,
2650 Create_SCC => Create_SCC);
2656 procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array) is
2658 if Debug_Flag_V then
2659 Write_Str ("Root = ");
2660 Write_Int (Int (Root));
2662 Write_Unit_Name (Units.Table (Root).Uname);
2664 Write_Int (Nodes'Length);
2665 Write_Line (" units:");
2667 for J in Nodes'Range loop
2669 Write_Int (Int (Nodes (J)));
2671 Write_Unit_Name (Units.Table (Nodes (J)).Uname);
2676 pragma Assert (Nodes (Nodes'First) = Root);
2677 pragma Assert (UNR.Table (Root).Nodes = null);
2678 UNR.Table (Root).Nodes := new Unit_Id_Array'(Nodes);
2680 for J in Nodes'Range loop
2681 pragma Assert (SCC (Nodes (J)) = No_Unit_Id);
2682 UNR.Table (Nodes (J)).SCC_Root := Root;
2690 function Successors (U : Unit_Id) return Unit_Id_Array is
2691 S : Successor_Id := UNR.Table (U).Successors;
2692 Tab : Unit_Id_Table;
2695 -- Pretend that a spec is a successor of its body (even though it
2696 -- isn't), just so both get included.
2698 if Units.Table (U).Utype = Is_Body then
2699 Append (Tab, Corresponding_Spec (U));
2702 -- Now include the real successors
2704 while S /= No_Successor loop
2705 pragma Assert (Succ.Table (S).Before = U);
2706 Append (Tab, Succ.Table (S).After);
2707 S := Succ.Table (S).Next;
2711 Result : constant Unit_Id_Array := Tab.Table (1 .. Last (Tab));
2719 -----------------------
2720 -- Init_SCC_Num_Pred --
2721 -----------------------
2723 procedure Init_SCC_Num_Pred (U : Unit_Id) is
2725 if UNR.Table (U).Visited then
2729 UNR.Table (U).Visited := True;
2732 S : Successor_Id := UNR.Table (U).Successors;
2735 while S /= No_Successor loop
2736 pragma Assert (Succ.Table (S).Before = U);
2737 Init_SCC_Num_Pred (Succ.Table (S).After);
2739 if SCC (U) /= SCC (Succ.Table (S).After) then
2740 UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred :=
2741 UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred + 1;
2744 S := Succ.Table (S).Next;
2747 end Init_SCC_Num_Pred;
2749 -- Start of processing for Compute_Unit_SCCs
2754 for Uref in UNR.First .. UNR.Last loop
2755 pragma Assert (not UNR.Table (Uref).Visited);
2759 for Uref in UNR.First .. UNR.Last loop
2760 Init_SCC_Num_Pred (Uref);
2763 -- Assert that SCC_Root of all units has been set to a valid unit,
2764 -- and that SCC_Num_Pred has not been modified in non-root units.
2766 for Uref in UNR.First .. UNR.Last loop
2767 pragma Assert (UNR.Table (Uref).SCC_Root /= No_Unit_Id);
2768 pragma Assert (UNR.Table (Uref).SCC_Root in UNR.First .. UNR.Last);
2770 if SCC (Uref) /= Uref then
2771 pragma Assert (UNR.Table (Uref).SCC_Num_Pred = 0);
2775 end Compute_Unit_SCCs;
2777 --------------------------
2778 -- Find_Elab_All_Errors --
2779 --------------------------
2781 procedure Find_Elab_All_Errors is
2782 Withed_Unit : Unit_Id;
2785 for U in Units.First .. Units.Last loop
2787 -- If this unit is not an interface to a stand-alone library,
2788 -- process WITH references for this unit ignoring interfaces to
2789 -- stand-alone libraries.
2791 if not Units.Table (U).SAL_Interface then
2792 for W in Units.Table (U).First_With ..
2793 Units.Table (U).Last_With
2795 if Withs.Table (W).Sfile /= No_File
2796 and then (not Withs.Table (W).SAL_Interface)
2798 -- Check for special case of withing a unit that does not
2801 if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then
2805 Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname);
2807 -- If it's Elaborate_All or Elab_All_Desirable, check
2808 -- that the withER and withEE are not in the same SCC.
2810 if Withs.Table (W).Elaborate_All
2811 or else Withs.Table (W).Elab_All_Desirable
2813 if SCC (U) = SCC (Withed_Unit) then
2814 Elab_Cycle_Found := True; -- ???
2816 -- We could probably give better error messages
2817 -- than Elab_Old here, but for now, to avoid
2818 -- disruption, we don't give any error here.
2819 -- Instead, we set the Elab_Cycle_Found flag above,
2820 -- and then run the Elab_Old algorithm to issue the
2821 -- error message. Ideally, we would like to print
2822 -- multiple errors rather than stopping after the
2827 ("illegal pragma Elaborate_All",
2839 end Find_Elab_All_Errors;
2841 ---------------------
2842 -- Find_Elab_Order --
2843 ---------------------
2845 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
2846 Best_So_Far : Unit_Id;
2850 -- Gather dependencies and output them if option set
2852 Gather_Dependencies;
2856 -- Initialize the no-predecessor list
2858 No_Pred := No_Unit_Id;
2859 for U in UNR.First .. UNR.Last loop
2860 if UNR.Table (U).Num_Pred = 0 then
2861 UNR.Table (U).Nextnp := No_Pred;
2866 -- OK, now we determine the elaboration order proper. All we do is to
2867 -- select the best choice from the no-predecessor list until all the
2868 -- nodes have been chosen.
2871 if Debug_Flag_N then
2872 Write_Line ("Outer loop");
2875 -- If there are no nodes with predecessors, then either we are
2876 -- done, as indicated by Num_Left being set to zero, or we have
2877 -- a circularity. In the latter case, diagnose the circularity,
2878 -- removing it from the graph and continue.
2879 -- ????But Diagnose_Elaboration_Problem always raises an
2880 -- exception, so the loop never goes around more than once.
2882 Get_No_Pred : while No_Pred = No_Unit_Id loop
2883 exit Outer when Num_Left < 1;
2884 Diagnose_Elaboration_Problem (Elab_Order);
2885 end loop Get_No_Pred;
2888 Best_So_Far := No_Unit_Id;
2890 -- Loop to choose best entry in No_Pred list
2892 No_Pred_Search : loop
2893 if Debug_Flag_N then
2894 Write_Str (" considering choice of ");
2895 Write_Unit_Name (Units.Table (U).Uname);
2898 if Units.Table (U).Elaborate_Body then
2900 (" Elaborate_Body = True, Num_Pred for body = ");
2902 (UNR.Table (Corresponding_Body (U)).Num_Pred);
2905 (" Elaborate_Body = False");
2911 -- Don't even consider units whose SCC is not ready. This
2912 -- ensures that all units of an SCC will be elaborated
2913 -- together, with no other units in between.
2915 if SCC_Num_Pred (U) = 0
2916 and then Better_Choice (U, Best_So_Far)
2918 if Debug_Flag_N then
2919 Write_Line (" tentatively chosen (best so far)");
2924 if Debug_Flag_N then
2925 Write_Line (" SCC not ready");
2929 U := UNR.Table (U).Nextnp;
2930 exit No_Pred_Search when U = No_Unit_Id;
2931 end loop No_Pred_Search;
2933 -- If there are no units on the No_Pred list whose SCC is ready,
2934 -- there must be a cycle. Defer to Elab_Old to print an error
2937 if Best_So_Far = No_Unit_Id then
2938 Elab_Cycle_Found := True;
2942 -- Choose the best candidate found
2944 Choose (Elab_Order, Best_So_Far, " [Best_So_Far]");
2946 -- If it's a spec with a body, and the body is not yet chosen,
2947 -- choose the body if possible. The case where the body is
2948 -- already chosen is Elaborate_Body; the above call to Choose
2949 -- the spec will also Choose the body.
2951 if Units.Table (Best_So_Far).Utype = Is_Spec
2953 (Corresponding_Body (Best_So_Far)).Elab_Position = 0
2956 Choose_The_Body : constant Boolean :=
2957 UNR.Table (Corresponding_Body
2958 (Best_So_Far)).Num_Pred = 0;
2961 if Debug_Flag_B then
2962 Write_Str ("Can we choose the body?... ");
2964 if Choose_The_Body then
2965 Write_Line ("Yes!");
2971 if Choose_The_Body then
2973 (Elab_Order => Elab_Order,
2974 Chosen => Corresponding_Body (Best_So_Far),
2980 -- Finally, choose all the rest of the units in the same SCC as
2981 -- Best_So_Far. If it hasn't been chosen (Elab_Position = 0), and
2982 -- it's ready to be chosen (Num_Pred = 0), then we can choose it.
2986 Chose_One_Or_More : Boolean := False;
2987 SCC : Unit_Id_Array renames Nodes (Best_So_Far).all;
2990 for J in SCC'Range loop
2991 if UNR.Table (SCC (J)).Elab_Position = 0
2992 and then UNR.Table (SCC (J)).Num_Pred = 0
2994 Chose_One_Or_More := True;
2995 Choose (Elab_Order, SCC (J), " [same SCC]");
2999 exit when not Chose_One_Or_More;
3004 Find_Elab_All_Errors;
3005 end Find_Elab_Order;
3011 function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr is
3013 return UNR.Table (SCC (U)).Nodes;
3020 function SCC (U : Unit_Id) return Unit_Id is
3022 return UNR.Table (U).SCC_Root;
3029 function SCC_Num_Pred (U : Unit_Id) return Int is
3031 return UNR.Table (SCC (U)).SCC_Num_Pred;
3038 procedure Write_SCC (U : Unit_Id) is
3039 pragma Assert (SCC (U) = U);
3041 for J in Nodes (U)'Range loop
3042 Write_Int (UNR.Table (Nodes (U) (J)).Elab_Position);
3044 Write_Unit_Name (Units.Table (Nodes (U) (J)).Uname);
3057 package body Elab_Old is
3059 ---------------------
3060 -- Find_Elab_Order --
3061 ---------------------
3063 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
3064 Best_So_Far : Unit_Id;
3068 -- Gather dependencies and output them if option set
3070 Gather_Dependencies;
3072 -- Initialize the no-predecessor list
3074 No_Pred := No_Unit_Id;
3075 for U in UNR.First .. UNR.Last loop
3076 if UNR.Table (U).Num_Pred = 0 then
3077 UNR.Table (U).Nextnp := No_Pred;
3082 -- OK, now we determine the elaboration order proper. All we do is to
3083 -- select the best choice from the no-predecessor list until all the
3084 -- nodes have been chosen.
3088 -- If there are no nodes with predecessors, then either we are
3089 -- done, as indicated by Num_Left being set to zero, or we have
3090 -- a circularity. In the latter case, diagnose the circularity,
3091 -- removing it from the graph and continue.
3092 -- ????But Diagnose_Elaboration_Problem always raises an
3093 -- exception, so the loop never goes around more than once.
3095 Get_No_Pred : while No_Pred = No_Unit_Id loop
3096 exit Outer when Num_Left < 1;
3097 Diagnose_Elaboration_Problem (Elab_Order);
3098 end loop Get_No_Pred;
3101 Best_So_Far := No_Unit_Id;
3103 -- Loop to choose best entry in No_Pred list
3105 No_Pred_Search : loop
3106 if Debug_Flag_N then
3107 Write_Str (" considering choice of ");
3108 Write_Unit_Name (Units.Table (U).Uname);
3111 if Units.Table (U).Elaborate_Body then
3113 (" Elaborate_Body = True, Num_Pred for body = ");
3115 (UNR.Table (Corresponding_Body (U)).Num_Pred);
3118 (" Elaborate_Body = False");
3124 -- This is a candididate to be considered for choice
3126 if Better_Choice (U, Best_So_Far) then
3127 if Debug_Flag_N then
3128 Write_Line (" tentatively chosen (best so far)");
3134 U := UNR.Table (U).Nextnp;
3135 exit No_Pred_Search when U = No_Unit_Id;
3136 end loop No_Pred_Search;
3138 -- Choose the best candidate found
3140 Choose (Elab_Order, Best_So_Far, " [Elab_Old Best_So_Far]");
3142 end Find_Elab_Order;