1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, 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
;
35 with System
.Case_Util
; use System
.Case_Util
;
41 -- We now have Elab_New, a new elaboration-order algorithm.
43 -- However, any change to elaboration order can break some programs.
44 -- Therefore, we are keeping the old algorithm in place, to be selected
47 -- The new algorithm has the following interesting properties:
49 -- * The static and dynamic models use the same elaboration order. The
50 -- static model might get an error, but if it does not, it will use
51 -- the same order as the dynamic model.
53 -- * Each SCC (see below) is elaborated together; that is, units from
54 -- different SCCs are not interspersed.
56 -- * In particular, this implies that if an SCC contains just a spec and
57 -- the corresponding body, and nothing else, the body will be
58 -- elaborated immediately after the spec. This is expected to result
59 -- in a better elaboration order for most programs, because in this
60 -- case, a call from outside the library unit cannot get ABE.
62 -- * Pragmas Elaborate_All (explicit and implicit) are ignored. Instead,
63 -- we behave as if every legal pragma Elaborate_All were present. That
64 -- is, if it would be legal to have "pragma Elaborate_All(Y);" on X,
65 -- then we behave as if such a pragma exists, even if it does not.
67 Do_Old
: constant Boolean := False;
68 Do_New
: constant Boolean := True;
69 -- True to enable the old and new algorithms, respectively. Used for
70 -- debugging/experimentation.
72 Doing_New
: Boolean := False;
73 -- True if we are currently doing the new algorithm. Print certain
74 -- messages only when doing the "new" elab order algorithm, so we don't get
75 -- duplicates. And use different heuristics in Better_Choice_Optimistic.
77 -- The following data structures are used to represent the graph that is
78 -- used to determine the elaboration order (using a topological sort).
80 -- The following structures are used to record successors. If B is a
81 -- successor of A in this table, it means that A must be elaborated before
82 -- B is elaborated. For example, if Y (body) says "with X;", then Y (body)
83 -- will be a successor of X (spec), and X (spec) will be a predecessor of
86 -- Note that we store the successors of each unit explicitly. We don't
87 -- store the predecessors, but we store a count of them.
89 -- The basic algorithm is to first compute a directed graph of units (type
90 -- Unit_Node_Record, below), with successors as edges. A unit is "ready"
91 -- (to be chosen as the next to be elaborated) if it has no predecessors
92 -- that have not yet been chosen. We use heuristics to decide which of the
93 -- ready units should be elaborated next, and "choose" that one (which
94 -- means we append it to the elaboration-order table).
96 type Successor_Id
is new Nat
;
97 -- Identification of single successor entry
99 No_Successor
: constant Successor_Id
:= 0;
100 -- Used to indicate end of list of successors
102 type Elab_All_Id
is new Nat
;
103 -- Identification of Elab_All entry link
105 No_Elab_All_Link
: constant Elab_All_Id
:= 0;
106 -- Used to indicate end of list
108 -- Succ_Reason indicates the reason for a particular elaboration link
112 -- After directly with's Before, so the spec of Before must be
113 -- elaborated before After is elaborated.
116 -- Before and After come from a pair of lines in the forced elaboration
120 -- After directly mentions Before in a pragma Elaborate, so the body of
121 -- Before must be elaborated before After is elaborated.
124 -- After either mentions Before directly in a pragma Elaborate_All, or
125 -- mentions a third unit, X, which itself requires that Before be
126 -- elaborated before unit X is elaborated. The Elab_All_Link list traces
127 -- the dependencies in the latter case.
130 -- This is just like Elab_All, except that the Elaborate_All was not
131 -- explicitly present in the source, but rather was created by the front
132 -- end, which decided that it was "desirable".
135 -- This is just like Elab, except that the Elaborate was not explicitly
136 -- present in the source, but rather was created by the front end, which
137 -- decided that it was "desirable".
140 -- After is a body, and Before is the corresponding spec
142 -- Successor_Link contains the information for one link
144 type Successor_Link
is record
152 -- Next successor on this list
154 Reason
: Succ_Reason
;
155 -- Reason for this link
158 -- Set True if this link is needed for the special Elaborate_Body
159 -- processing described below.
161 Reason_Unit
: Unit_Id
;
162 -- For Reason = Elab, or Elab_All or Elab_Desirable, records the unit
163 -- containing the pragma leading to the link.
165 Elab_All_Link
: Elab_All_Id
;
166 -- If Reason = Elab_All or Elab_Desirable, then this points to the
167 -- first element in a list of Elab_All entries that record the with
168 -- chain resulting in this particular dependency.
171 -- Note on handling of Elaborate_Body. Basically, if we have a pragma
172 -- Elaborate_Body in a unit, it means that the spec and body have to be
173 -- handled as a single entity from the point of view of determining an
174 -- elaboration order. What we do is to essentially remove the body from
175 -- consideration completely, and transfer all its links (other than the
176 -- spec link) to the spec. Then when the spec gets chosen, we choose the
177 -- body right afterwards. We mark the links that get moved from the body to
178 -- the spec by setting their Elab_Body flag True, so that we can understand
181 Succ_First
: constant := 1;
183 package Succ
is new Table
.Table
184 (Table_Component_Type
=> Successor_Link
,
185 Table_Index_Type
=> Successor_Id
,
186 Table_Low_Bound
=> Succ_First
,
187 Table_Initial
=> 500,
188 Table_Increment
=> 200,
189 Table_Name
=> "Succ");
191 -- For the case of Elaborate_All, the following table is used to record
192 -- chains of with relationships that lead to the Elab_All link. These are
193 -- used solely for diagnostic purposes
195 type Elab_All_Entry
is record
196 Needed_By
: Unit_Name_Type
;
197 -- Name of unit from which referencing unit was with'ed or otherwise
198 -- needed as a result of Elaborate_All or Elaborate_Desirable.
200 Next_Elab
: Elab_All_Id
;
201 -- Link to next entry on chain (No_Elab_All_Link marks end of list)
204 package Elab_All_Entries
is new Table
.Table
205 (Table_Component_Type
=> Elab_All_Entry
,
206 Table_Index_Type
=> Elab_All_Id
,
207 Table_Low_Bound
=> 1,
208 Table_Initial
=> 2000,
209 Table_Increment
=> 200,
210 Table_Name
=> "Elab_All_Entries");
212 type Unit_Id_Array_Ptr
is access Unit_Id_Array
;
214 -- A Unit_Node_Record is built for each active unit
216 type Unit_Node_Record
is record
217 Successors
: Successor_Id
;
218 -- Pointer to list of links for successor nodes
221 -- Number of predecessors for this unit that have not yet been chosen.
222 -- Normally non-negative, but can go negative in the case of units
223 -- chosen by the diagnose error procedure (when cycles are being removed
227 -- Forward pointer for list of units with no predecessors
230 -- Used in computing transitive closure for Elaborate_All and also in
231 -- locating cycles and paths in the diagnose routines.
234 -- Initialized to zero. Set non-zero when a unit is chosen and placed in
235 -- the elaboration order. The value represents the ordinal position in
236 -- the elaboration order.
238 -- The following are for Elab_New. We compute the strongly connected
239 -- components (SCCs) of the directed graph of units. The edges are the
240 -- Successors, which do not include pragmas Elaborate_All (explicit or
241 -- implicit) in Elab_New. In addition, we assume there is a edge
242 -- pointing from a body to its corresponding spec; this edge is not
243 -- included in Successors, because of course a spec is elaborated BEFORE
244 -- its body, not after.
247 -- Each unit points to the root of its SCC, which is just an arbitrary
248 -- member of the SCC. Two units are in the same SCC if and only if their
249 -- SCC_Roots are equal. U is the root of its SCC if and only if
252 Nodes
: Unit_Id_Array_Ptr
;
253 -- Present only in the root of an SCC. This is the set of units in the
254 -- SCC, in no particular order.
257 -- Present only in the root of an SCC. This is the number of predecessor
258 -- units of the SCC that are in other SCCs, and that have not yet been
261 Validate_Seen
: Boolean := False;
262 -- See procedure Validate below
265 package UNR
is new Table
.Table
266 (Table_Component_Type
=> Unit_Node_Record
,
267 Table_Index_Type
=> Unit_Id
,
268 Table_Low_Bound
=> First_Unit_Entry
,
269 Table_Initial
=> 500,
270 Table_Increment
=> 200,
271 Table_Name
=> "UNR");
274 -- Head of list of items with no predecessors
277 -- Number of entries not yet dealt with
280 -- Current unit, set by Gather_Dependencies, and picked up in Build_Link to
281 -- set the Reason_Unit field of the created dependency link.
284 -- Number of units chosen in the elaboration order so far
286 Diagnose_Elaboration_Problem_Called
: Boolean := False;
287 -- True if Diagnose_Elaboration_Problem was called. Used in an assertion.
289 -----------------------
290 -- Local Subprograms --
291 -----------------------
293 function Debug_Flag_Older
return Boolean;
294 function Debug_Flag_Old
return Boolean;
295 -- True if debug flags select the old or older algorithms. Pretty much any
296 -- change to elaboration order can break some programs. For example,
297 -- programs can depend on elaboration order even without failing
298 -- access-before-elaboration checks. A trivial example is a program that
299 -- prints text during elaboration. Therefore, we have flags to revert to
300 -- the old(er) algorithms.
302 procedure Validate
(Order
: Unit_Id_Array
; Doing_New
: Boolean);
303 -- Assert that certain properties are true
305 function Better_Choice_Optimistic
307 U2
: Unit_Id
) return Boolean;
308 -- U1 and U2 are both permitted candidates for selection as the next unit
309 -- to be elaborated. This function determines whether U1 is a better choice
310 -- than U2, i.e. should be elaborated in preference to U2, based on a set
311 -- of heuristics that establish a friendly and predictable order (see body
312 -- for details). The result is True if U1 is a better choice than U2, and
313 -- False if it is a worse choice, or there is no preference between them.
315 function Better_Choice_Pessimistic
317 U2
: Unit_Id
) return Boolean;
318 -- This is like Better_Choice_Optimistic, and has the same interface, but
319 -- returns true if U1 is a worse choice than U2 in the sense of the -p
320 -- (pessimistic elaboration order) switch. We still have to obey Ada rules,
321 -- so it is not quite the direct inverse of Better_Choice_Optimistic.
323 function Better_Choice
(U1
: Unit_Id
; U2
: Unit_Id
) return Boolean;
324 -- Calls Better_Choice_Optimistic or Better_Choice_Pessimistic as
325 -- appropriate. Also takes care of the U2 = No_Unit_Id case.
331 Ea_Id
: Elab_All_Id
:= No_Elab_All_Link
);
332 -- Establish a successor link, Before must be elaborated before After, and
333 -- the reason for the link is R. Ea_Id is the contents to be placed in the
334 -- Elab_All_Link of the entry.
337 (Elab_Order
: in out Unit_Id_Table
;
340 -- Chosen is the next entry chosen in the elaboration order. This procedure
341 -- updates all data structures appropriately.
343 function Corresponding_Body
(U
: Unit_Id
) return Unit_Id
;
344 pragma Inline
(Corresponding_Body
);
345 -- Given a unit that is a spec for which there is a separate body, return
346 -- the unit id of the body. It is an error to call this routine with a unit
347 -- that is not a spec, or that does not have a separate body.
349 function Corresponding_Spec
(U
: Unit_Id
) return Unit_Id
;
350 pragma Inline
(Corresponding_Spec
);
351 -- Given a unit that is a body for which there is a separate spec, return
352 -- the unit id of the spec. It is an error to call this routine with a unit
353 -- that is not a body, or that does not have a separate spec.
355 procedure Diagnose_Elaboration_Problem
356 (Elab_Order
: in out Unit_Id_Table
);
357 pragma No_Return
(Diagnose_Elaboration_Problem
);
358 -- Called when no elaboration order can be found. Outputs an appropriate
359 -- diagnosis of the problem, and then abandons the bind.
361 procedure Elab_All_Links
364 Reason
: Succ_Reason
;
366 -- Used to compute the transitive closure of elaboration links for an
367 -- Elaborate_All pragma (Reason = Elab_All) or for an indication of
368 -- Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has a
369 -- pragma Elaborate_All or the front end has determined that a reference
370 -- probably requires Elaborate_All, and unit Before must be previously
371 -- elaborated. First a link is built making sure that unit Before is
372 -- elaborated before After, then a recursive call ensures that we also
373 -- build links for any units needed by Before (i.e. these units must/should
374 -- also be elaborated before After). Link is used to build a chain of
375 -- Elab_All_Entries to explain the reason for a link. The value passed is
378 procedure Elab_Error_Msg
(S
: Successor_Id
);
379 -- Given a successor link, outputs an error message of the form
380 -- "$ must be elaborated before $ ..." where ... is the reason.
382 procedure Force_Elab_Order
;
383 -- Gather dependencies from the forced elaboration order file (-f switch)
385 procedure Gather_Dependencies
;
386 -- Compute dependencies, building the Succ and UNR tables
389 -- Initialize global data structures in this package body
391 function Is_Body_Unit
(U
: Unit_Id
) return Boolean;
392 pragma Inline
(Is_Body_Unit
);
393 -- Determines if given unit is a body
395 function Is_Pure_Or_Preelab_Unit
(U
: Unit_Id
) return Boolean;
396 -- Returns True if corresponding unit is Pure or Preelaborate. Includes
397 -- dealing with testing flags on spec if it is given a body.
399 function Is_Waiting_Body
(U
: Unit_Id
) return Boolean;
400 pragma Inline
(Is_Waiting_Body
);
401 -- Determines if U is a waiting body, defined as a body that has
402 -- not been elaborated, but whose spec has been elaborated.
404 function Make_Elab_All_Entry
405 (Unam
: Unit_Name_Type
;
406 Link
: Elab_All_Id
) return Elab_All_Id
;
407 -- Make an Elab_All_Entries table entry with the given Unam and Link
409 function Unit_Id_Of
(Uname
: Unit_Name_Type
) return Unit_Id
;
410 -- This function uses the Info field set in the names table to obtain
411 -- the unit Id of a unit, given its name id value.
413 procedure Write_Closure
(Order
: Unit_Id_Array
);
414 -- Write the closure. This is for the -R and -Ra switches, "list closure
417 procedure Write_Dependencies
;
418 -- Write out dependencies (called only if appropriate option is set)
420 procedure Write_Elab_All_Chain
(S
: Successor_Id
);
421 -- If the reason for the link S is Elaborate_All or Elaborate_Desirable,
422 -- then this routine will output the "needed by" explanation chain.
424 procedure Write_Elab_Order
(Order
: Unit_Id_Array
; Title
: String);
425 -- Display elaboration order. This is for the -l switch. Title is a heading
426 -- to print; an empty string is passed to indicate Zero_Formatting.
430 -- Implementation of the new algorithm
432 procedure Write_SCC
(U
: Unit_Id
);
433 -- Write the unit names of the units in the SCC in which U lives
435 procedure Find_Elab_Order
(Elab_Order
: out Unit_Id_Table
);
437 Elab_Cycle_Found
: Boolean := False;
438 -- Set True if Find_Elab_Order found a cycle (usually an illegal pragma
439 -- Elaborate_All, explicit or implicit).
441 function SCC
(U
: Unit_Id
) return Unit_Id
;
442 -- The root of the strongly connected component containing U
444 function SCC_Num_Pred
(U
: Unit_Id
) return Int
;
445 -- The SCC_Num_Pred of the SCC in which U lives
447 function Nodes
(U
: Unit_Id
) return Unit_Id_Array_Ptr
;
448 -- The nodes of the strongly connected component containing U
456 -- Implementation of the old algorithm
458 procedure Find_Elab_Order
(Elab_Order
: out Unit_Id_Table
);
462 -- Most of the code is shared between old and new; such code is outside
463 -- packages Elab_Old and Elab_New.
469 function Better_Choice
(U1
: Unit_Id
; U2
: Unit_Id
) return Boolean is
470 pragma Assert
(U1
/= No_Unit_Id
);
472 if U2
= No_Unit_Id
then
476 if Pessimistic_Elab_Order
then
477 return Better_Choice_Pessimistic
(U1
, U2
);
479 return Better_Choice_Optimistic
(U1
, U2
);
483 ------------------------------
484 -- Better_Choice_Optimistic --
485 ------------------------------
487 function Better_Choice_Optimistic
489 U2
: Unit_Id
) return Boolean
491 UT1
: Unit_Record
renames Units
.Table
(U1
);
492 UT2
: Unit_Record
renames Units
.Table
(U2
);
496 Write_Str
("Better_Choice_Optimistic (");
497 Write_Unit_Name
(UT1
.Uname
);
499 Write_Unit_Name
(UT2
.Uname
);
503 -- Note: the checks here are applied in sequence, and the ordering is
504 -- significant (i.e. the more important criteria are applied first).
506 -- Prefer a waiting body to one that is not a waiting body
508 if Is_Waiting_Body
(U1
) and then not Is_Waiting_Body
(U2
) then
510 Write_Line
(" True: u1 is waiting body, u2 is not");
515 elsif Is_Waiting_Body
(U2
) and then not Is_Waiting_Body
(U1
) then
517 Write_Line
(" False: u2 is waiting body, u1 is not");
522 -- Prefer a predefined unit to a non-predefined unit
524 elsif UT1
.Predefined
and then not UT2
.Predefined
then
526 Write_Line
(" True: u1 is predefined, u2 is not");
531 elsif UT2
.Predefined
and then not UT1
.Predefined
then
533 Write_Line
(" False: u2 is predefined, u1 is not");
538 -- Prefer an internal unit to a non-internal unit
540 elsif UT1
.Internal
and then not UT2
.Internal
then
542 Write_Line
(" True: u1 is internal, u2 is not");
546 elsif UT2
.Internal
and then not UT1
.Internal
then
548 Write_Line
(" False: u2 is internal, u1 is not");
553 -- Prefer a pure or preelaborated unit to one that is not. Pure should
554 -- come before preelaborated.
556 elsif Is_Pure_Or_Preelab_Unit
(U1
)
558 Is_Pure_Or_Preelab_Unit
(U2
)
561 Write_Line
(" True: u1 is pure/preelab, u2 is not");
566 elsif Is_Pure_Or_Preelab_Unit
(U2
)
568 Is_Pure_Or_Preelab_Unit
(U1
)
571 Write_Line
(" False: u2 is pure/preelab, u1 is not");
576 -- Prefer a body to a spec
578 elsif Is_Body_Unit
(U1
) and then not Is_Body_Unit
(U2
) then
580 Write_Line
(" True: u1 is body, u2 is not");
585 elsif Is_Body_Unit
(U2
) and then not Is_Body_Unit
(U1
) then
587 Write_Line
(" False: u2 is body, u1 is not");
592 -- If both are waiting bodies, then prefer the one whose spec is more
593 -- recently elaborated. Consider the following:
599 -- The normal waiting body preference would have placed the body of A
600 -- before the spec of B if it could. Since it could not, then it must be
601 -- the case that A depends on B. It is therefore a good idea to put the
604 elsif Is_Waiting_Body
(U1
) and then Is_Waiting_Body
(U2
) then
606 Result
: constant Boolean :=
607 UNR
.Table
(Corresponding_Spec
(U1
)).Elab_Position
>
608 UNR
.Table
(Corresponding_Spec
(U2
)).Elab_Position
;
612 Write_Line
(" True: based on waiting body elab positions");
614 Write_Line
(" False: based on waiting body elab positions");
622 -- Remaining choice rules are disabled by Debug flag -do
624 if not Debug_Flag_Older
then
626 -- The following deal with the case of specs that have been marked
627 -- as Elaborate_Body_Desirable. We generally want to delay these
628 -- specs as long as possible, so that the bodies have a better chance
629 -- of being elaborated closer to the specs.
631 -- If we have two units, one of which is a spec for which this flag
632 -- is set, and the other is not, we prefer to delay the spec for
633 -- which the flag is set.
635 if not UT1
.Elaborate_Body_Desirable
636 and then UT2
.Elaborate_Body_Desirable
639 Write_Line
(" True: u1 is elab body desirable, u2 is not");
644 elsif not UT2
.Elaborate_Body_Desirable
645 and then UT1
.Elaborate_Body_Desirable
648 Write_Line
(" False: u1 is elab body desirable, u2 is not");
653 -- If we have two specs that are both marked as Elaborate_Body
654 -- desirable, we prefer the one whose body is nearer to being able
655 -- to be elaborated, based on the Num_Pred count. This helps to
656 -- ensure bodies are as close to specs as possible.
658 elsif UT1
.Elaborate_Body_Desirable
659 and then UT2
.Elaborate_Body_Desirable
662 Result
: constant Boolean :=
663 UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
<
664 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
;
668 Write_Line
(" True based on Num_Pred compare");
670 Write_Line
(" False based on Num_Pred compare");
679 -- If we have two specs in the same SCC, choose the one whose body is
680 -- closer to being ready.
683 and then SCC
(U1
) = SCC
(U2
)
684 and then Units
.Table
(U1
).Utype
= Is_Spec
685 and then Units
.Table
(U2
).Utype
= Is_Spec
686 and then UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
/=
687 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
689 if UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
<
690 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
693 Write_Str
(" True: same SCC; ");
694 Write_Int
(UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
);
696 Write_Int
(UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
);
703 Write_Str
(" False: same SCC; ");
704 Write_Int
(UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
);
706 Write_Int
(UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
);
714 -- If we fall through, it means that no preference rule applies, so we
715 -- use alphabetical order to at least give a deterministic result.
718 Write_Line
(" choose on alpha order");
721 return Uname_Less
(UT1
.Uname
, UT2
.Uname
);
722 end Better_Choice_Optimistic
;
724 -------------------------------
725 -- Better_Choice_Pessimistic --
726 -------------------------------
728 function Better_Choice_Pessimistic
730 U2
: Unit_Id
) return Boolean
732 UT1
: Unit_Record
renames Units
.Table
(U1
);
733 UT2
: Unit_Record
renames Units
.Table
(U2
);
737 Write_Str
("Better_Choice_Pessimistic (");
738 Write_Unit_Name
(UT1
.Uname
);
740 Write_Unit_Name
(UT2
.Uname
);
744 -- Note: the checks here are applied in sequence, and the ordering is
745 -- significant (i.e. the more important criteria are applied first).
747 -- If either unit is predefined or internal, then we use the normal
748 -- Better_Choice_Optimistic rule, since we don't want to disturb the
749 -- elaboration rules of the language with -p; same treatment for
752 -- Prefer a predefined unit to a non-predefined unit
754 if UT1
.Predefined
and then not UT2
.Predefined
then
756 Write_Line
(" True: u1 is predefined, u2 is not");
761 elsif UT2
.Predefined
and then not UT1
.Predefined
then
763 Write_Line
(" False: u2 is predefined, u1 is not");
768 -- Prefer an internal unit to a non-internal unit
770 elsif UT1
.Internal
and then not UT2
.Internal
then
772 Write_Line
(" True: u1 is internal, u2 is not");
777 elsif UT2
.Internal
and then not UT1
.Internal
then
779 Write_Line
(" False: u2 is internal, u1 is not");
784 -- Prefer a pure or preelaborated unit to one that is not
786 elsif Is_Pure_Or_Preelab_Unit
(U1
)
788 Is_Pure_Or_Preelab_Unit
(U2
)
791 Write_Line
(" True: u1 is pure/preelab, u2 is not");
796 elsif Is_Pure_Or_Preelab_Unit
(U2
)
798 Is_Pure_Or_Preelab_Unit
(U1
)
801 Write_Line
(" False: u2 is pure/preelab, u1 is not");
806 -- Prefer anything else to a waiting body. We want to make bodies wait
807 -- as long as possible, till we are forced to choose them.
809 elsif Is_Waiting_Body
(U1
) and then not Is_Waiting_Body
(U2
) then
811 Write_Line
(" False: u1 is waiting body, u2 is not");
816 elsif Is_Waiting_Body
(U2
) and then not Is_Waiting_Body
(U1
) then
818 Write_Line
(" True: u2 is waiting body, u1 is not");
823 -- Prefer a spec to a body (this is mandatory)
825 elsif Is_Body_Unit
(U1
) and then not Is_Body_Unit
(U2
) then
827 Write_Line
(" False: u1 is body, u2 is not");
832 elsif Is_Body_Unit
(U2
) and then not Is_Body_Unit
(U1
) then
834 Write_Line
(" True: u2 is body, u1 is not");
839 -- If both are waiting bodies, then prefer the one whose spec is less
840 -- recently elaborated. Consider the following:
846 -- The normal waiting body preference would have placed the body of A
847 -- before the spec of B if it could. Since it could not, then it must be
848 -- the case that A depends on B. It is therefore a good idea to put the
849 -- body of B last so that if there is an elaboration order problem, we
850 -- will find it (that's what pessimistic order is about).
852 elsif Is_Waiting_Body
(U1
) and then Is_Waiting_Body
(U2
) then
854 Result
: constant Boolean :=
855 UNR
.Table
(Corresponding_Spec
(U1
)).Elab_Position
<
856 UNR
.Table
(Corresponding_Spec
(U2
)).Elab_Position
;
860 Write_Line
(" True: based on waiting body elab positions");
862 Write_Line
(" False: based on waiting body elab positions");
870 -- Remaining choice rules are disabled by Debug flag -do
872 if not Debug_Flag_Older
then
874 -- The following deal with the case of specs that have been marked as
875 -- Elaborate_Body_Desirable. In the normal case, we generally want to
876 -- delay the elaboration of these specs as long as possible, so that
877 -- bodies have better chance of being elaborated closer to the specs.
878 -- Better_Choice_Pessimistic as usual wants to do the opposite and
879 -- elaborate such specs as early as possible.
881 -- If we have two units, one of which is a spec for which this flag
882 -- is set, and the other is not, we normally prefer to delay the spec
883 -- for which the flag is set, so again Better_Choice_Pessimistic does
886 if not UT1
.Elaborate_Body_Desirable
887 and then UT2
.Elaborate_Body_Desirable
890 Write_Line
(" False: u1 is elab body desirable, u2 is not");
895 elsif not UT2
.Elaborate_Body_Desirable
896 and then UT1
.Elaborate_Body_Desirable
899 Write_Line
(" True: u1 is elab body desirable, u2 is not");
904 -- If we have two specs that are both marked as Elaborate_Body
905 -- desirable, we normally prefer the one whose body is nearer to
906 -- being able to be elaborated, based on the Num_Pred count. This
907 -- helps to ensure bodies are as close to specs as possible. As
908 -- usual, Better_Choice_Pessimistic does the opposite.
910 elsif UT1
.Elaborate_Body_Desirable
911 and then UT2
.Elaborate_Body_Desirable
914 Result
: constant Boolean :=
915 UNR
.Table
(Corresponding_Body
(U1
)).Num_Pred
>=
916 UNR
.Table
(Corresponding_Body
(U2
)).Num_Pred
;
920 Write_Line
(" True based on Num_Pred compare");
922 Write_Line
(" False based on Num_Pred compare");
931 -- If we fall through, it means that no preference rule applies, so we
932 -- use alphabetical order to at least give a deterministic result. Since
933 -- Better_Choice_Pessimistic is in the business of stirring up the
934 -- order, we will use reverse alphabetical ordering.
937 Write_Line
(" choose on reverse alpha order");
940 return Uname_Less
(UT2
.Uname
, UT1
.Uname
);
941 end Better_Choice_Pessimistic
;
951 Ea_Id
: Elab_All_Id
:= No_Elab_All_Link
)
958 After
=> No_Unit_Id
, -- filled in below
959 Next
=> UNR
.Table
(Before
).Successors
,
961 Elab_Body
=> False, -- set correctly below
962 Reason_Unit
=> Cur_Unit
,
963 Elab_All_Link
=> Ea_Id
));
964 UNR
.Table
(Before
).Successors
:= Succ
.Last
;
966 -- Deal with special Elab_Body case. If the After of this link is
967 -- a body whose spec has Elaborate_All set, and this is not the link
968 -- directly from the body to the spec, then we make the After of the
969 -- link reference its spec instead, marking the link appropriately.
971 if Units
.Table
(After
).Utype
= Is_Body
then
972 Cspec
:= Corresponding_Spec
(After
);
974 if Units
.Table
(Cspec
).Elaborate_Body
975 and then Cspec
/= Before
977 Succ
.Table
(Succ
.Last
).After
:= Cspec
;
978 Succ
.Table
(Succ
.Last
).Elab_Body
:= True;
979 UNR
.Table
(Cspec
).Num_Pred
:= UNR
.Table
(Cspec
).Num_Pred
+ 1;
984 -- Fall through on normal case
986 Succ
.Table
(Succ
.Last
).After
:= After
;
987 Succ
.Table
(Succ
.Last
).Elab_Body
:= False;
988 UNR
.Table
(After
).Num_Pred
:= UNR
.Table
(After
).Num_Pred
+ 1;
996 (Elab_Order
: in out Unit_Id_Table
;
1000 pragma Assert
(Chosen
/= No_Unit_Id
);
1005 if Debug_Flag_C
then
1006 Write_Str
("Choosing Unit ");
1007 Write_Unit_Name
(Units
.Table
(Chosen
).Uname
);
1011 -- We shouldn't be choosing something with unelaborated predecessors,
1012 -- and we shouldn't call this twice on the same unit. But that's not
1013 -- true when this is called from Diagnose_Elaboration_Problem.
1015 if Errors_Detected
= 0 then
1016 pragma Assert
(UNR
.Table
(Chosen
).Num_Pred
= 0);
1017 pragma Assert
(UNR
.Table
(Chosen
).Elab_Position
= 0);
1018 pragma Assert
(not Doing_New
or else SCC_Num_Pred
(Chosen
) = 0);
1022 -- Add to elaboration order. Note that units having no elaboration code
1023 -- are not treated specially yet. The special casing of this is in
1024 -- Bindgen, where Gen_Elab_Calls skips over them. Meanwhile we need them
1025 -- here, because the object file list is also driven by the contents of
1026 -- the Elab_Order table.
1028 Append
(Elab_Order
, Chosen
);
1030 -- Remove from No_Pred list. This is a little inefficient and may be we
1031 -- should doubly link the list, but it will do for now.
1033 if No_Pred
= Chosen
then
1034 No_Pred
:= UNR
.Table
(Chosen
).Nextnp
;
1037 while U
/= No_Unit_Id
loop
1038 if UNR
.Table
(U
).Nextnp
= Chosen
then
1039 UNR
.Table
(U
).Nextnp
:= UNR
.Table
(Chosen
).Nextnp
;
1043 U
:= UNR
.Table
(U
).Nextnp
;
1046 -- Here if we didn't find it on the No_Pred list. This can happen
1047 -- only in calls from the Diagnose_Elaboration_Problem routine,
1048 -- where cycles are being removed arbitrarily from the graph.
1050 pragma Assert
(Errors_Detected
> 0);
1051 <<Done_Removal
>> null;
1054 -- For all successors, decrement the number of predecessors, and if it
1055 -- becomes zero, then add to no-predecessor list.
1057 S
:= UNR
.Table
(Chosen
).Successors
;
1058 while S
/= No_Successor
loop
1059 U
:= Succ
.Table
(S
).After
;
1060 UNR
.Table
(U
).Num_Pred
:= UNR
.Table
(U
).Num_Pred
- 1;
1062 if Debug_Flag_N
then
1063 Write_Str
(" decrementing Num_Pred for unit ");
1064 Write_Unit_Name
(Units
.Table
(U
).Uname
);
1065 Write_Str
(" new value = ");
1066 Write_Int
(UNR
.Table
(U
).Num_Pred
);
1070 if UNR
.Table
(U
).Num_Pred
= 0 then
1071 UNR
.Table
(U
).Nextnp
:= No_Pred
;
1075 if Doing_New
and then SCC
(U
) /= SCC
(Chosen
) then
1076 UNR
.Table
(SCC
(U
)).SCC_Num_Pred
:=
1077 UNR
.Table
(SCC
(U
)).SCC_Num_Pred
- 1;
1079 if Debug_Flag_N
then
1080 Write_Str
(" decrementing SCC_Num_Pred for unit ");
1081 Write_Unit_Name
(Units
.Table
(U
).Uname
);
1082 Write_Str
(" new value = ");
1083 Write_Int
(SCC_Num_Pred
(U
));
1088 S
:= Succ
.Table
(S
).Next
;
1091 -- All done, adjust number of units left count and set elaboration pos
1093 Num_Left
:= Num_Left
- 1;
1094 Num_Chosen
:= Num_Chosen
+ 1;
1097 (Errors_Detected
> 0 or else Num_Chosen
= Last
(Elab_Order
));
1098 pragma Assert
(Units
.Last
= UNR
.Last
);
1099 pragma Assert
(Num_Chosen
+ Num_Left
= Int
(UNR
.Last
));
1101 if Debug_Flag_C
then
1103 Write_Int
(Int
(Num_Chosen
));
1105 Write_Int
(Num_Left
);
1107 Write_Int
(Int
(UNR
.Last
));
1111 UNR
.Table
(Chosen
).Elab_Position
:= Num_Chosen
;
1113 -- If we just chose a spec with Elaborate_Body set, then we must
1114 -- immediately elaborate the body, before any other units.
1116 if Units
.Table
(Chosen
).Elaborate_Body
then
1118 -- If the unit is a spec only, then there is no body. This is a bit
1119 -- odd given that Elaborate_Body is here, but it is valid in an RCI
1120 -- unit, where we only have the interface in the stub bind.
1122 if Units
.Table
(Chosen
).Utype
= Is_Spec_Only
1123 and then Units
.Table
(Chosen
).RCI
1128 (Elab_Order
=> Elab_Order
,
1129 Chosen
=> Corresponding_Body
(Chosen
),
1130 Msg
=> " [Elaborate_Body]");
1135 ------------------------
1136 -- Corresponding_Body --
1137 ------------------------
1139 -- Currently if the body and spec are separate, then they appear as two
1140 -- separate units in the same ALI file, with the body appearing first and
1141 -- the spec appearing second.
1143 function Corresponding_Body
(U
: Unit_Id
) return Unit_Id
is
1145 pragma Assert
(Units
.Table
(U
).Utype
= Is_Spec
);
1147 end Corresponding_Body
;
1149 ------------------------
1150 -- Corresponding_Spec --
1151 ------------------------
1153 -- Currently if the body and spec are separate, then they appear as two
1154 -- separate units in the same ALI file, with the body appearing first and
1155 -- the spec appearing second.
1157 function Corresponding_Spec
(U
: Unit_Id
) return Unit_Id
is
1159 pragma Assert
(Units
.Table
(U
).Utype
= Is_Body
);
1161 end Corresponding_Spec
;
1163 --------------------
1164 -- Debug_Flag_Old --
1165 --------------------
1167 function Debug_Flag_Old
return Boolean is
1169 -- If the user specified both flags, we want to use the older algorithm,
1170 -- rather than some confusing mix of the two.
1172 return Debug_Flag_P
and not Debug_Flag_O
;
1175 ----------------------
1176 -- Debug_Flag_Older --
1177 ----------------------
1179 function Debug_Flag_Older
return Boolean is
1181 return Debug_Flag_O
;
1182 end Debug_Flag_Older
;
1184 ----------------------------------
1185 -- Diagnose_Elaboration_Problem --
1186 ----------------------------------
1188 procedure Diagnose_Elaboration_Problem
1189 (Elab_Order
: in out Unit_Id_Table
)
1194 ML
: Nat
) return Boolean;
1195 -- Recursive routine used to find a path from node Ufrom to node Uto.
1196 -- If a path exists, returns True and outputs an appropriate set of
1197 -- error messages giving the path. Also calls Choose for each of the
1198 -- nodes so that they get removed from the remaining set. There are
1199 -- two cases of calls, either Ufrom = Uto for an attempt to find a
1200 -- cycle, or Ufrom is a spec and Uto the corresponding body for the
1201 -- case of an unsatisfiable Elaborate_Body pragma. ML is the minimum
1202 -- acceptable length for a path.
1211 ML
: Nat
) return Boolean
1213 function Find_Link
(U
: Unit_Id
; PL
: Nat
) return Boolean;
1214 -- This is the inner recursive routine, it determines if a path
1215 -- exists from U to Uto, and if so returns True and outputs the
1216 -- appropriate set of error messages. PL is the path length
1222 function Find_Link
(U
: Unit_Id
; PL
: Nat
) return Boolean is
1226 -- Recursion ends if we are at terminating node and the path is
1227 -- sufficiently long, generate error message and return True.
1229 if U
= Uto
and then PL
>= ML
then
1230 Choose
(Elab_Order
, U
, " [Find_Link: base]");
1233 -- All done if already visited
1235 elsif UNR
.Table
(U
).Visited
then
1238 -- Otherwise mark as visited and look at all successors
1241 UNR
.Table
(U
).Visited
:= True;
1243 S
:= UNR
.Table
(U
).Successors
;
1244 while S
/= No_Successor
loop
1245 if Find_Link
(Succ
.Table
(S
).After
, PL
+ 1) then
1247 Choose
(Elab_Order
, U
, " [Find_Link: recursive]");
1251 S
:= Succ
.Table
(S
).Next
;
1254 -- Falling through means this does not lead to a path
1260 -- Start of processing for Find_Path
1263 -- Initialize all non-chosen nodes to not visited yet
1265 for U
in Units
.First
.. Units
.Last
loop
1266 UNR
.Table
(U
).Visited
:= UNR
.Table
(U
).Elab_Position
/= 0;
1269 -- Now try to find the path
1271 return Find_Link
(Ufrom
, 0);
1274 -- Start of processing for Diagnose_Elaboration_Problem
1277 Diagnose_Elaboration_Problem_Called
:= True;
1280 -- Output state of things if debug flag N set
1282 if Debug_Flag_N
then
1289 Write_Line
("Diagnose_Elaboration_Problem called");
1290 Write_Line
("List of remaining unchosen units and predecessors");
1292 for U
in Units
.First
.. Units
.Last
loop
1293 if UNR
.Table
(U
).Elab_Position
= 0 then
1294 NP
:= UNR
.Table
(U
).Num_Pred
;
1296 Write_Str
(" Unchosen unit: #");
1297 Write_Int
(Int
(U
));
1299 Write_Unit_Name
(Units
.Table
(U
).Uname
);
1300 Write_Str
(" (Num_Pred = ");
1305 if Units
.Table
(U
).Elaborate_Body
then
1307 (" (not chosen because of Elaborate_Body)");
1309 Write_Line
(" ****************** why not chosen?");
1313 -- Search links list to find unchosen predecessors
1315 for S
in Succ
.First
.. Succ
.Last
loop
1317 SL
: Successor_Link
renames Succ
.Table
(S
);
1321 and then UNR
.Table
(SL
.Before
).Elab_Position
= 0
1323 Write_Str
(" unchosen predecessor: #");
1324 Write_Int
(Int
(SL
.Before
));
1326 Write_Unit_Name
(Units
.Table
(SL
.Before
).Uname
);
1334 Write_Line
(" **************** Num_Pred value wrong!");
1341 -- Output the header for the error, and manually increment the error
1342 -- count. We are using Error_Msg_Output rather than Error_Msg here for
1345 -- This is really only one error, not one for each line
1346 -- We want this output on standard output since it is voluminous
1348 -- But we do need to deal with the error count manually in this case
1350 Errors_Detected
:= Errors_Detected
+ 1;
1351 Error_Msg_Output
("elaboration circularity detected", Info
=> False);
1353 -- Try to find cycles starting with any of the remaining nodes that have
1354 -- not yet been chosen. There must be at least one (there is some reason
1355 -- we are being called).
1357 for U
in Units
.First
.. Units
.Last
loop
1358 if UNR
.Table
(U
).Elab_Position
= 0 then
1359 if Find_Path
(U
, U
, 1) then
1360 raise Unrecoverable_Error
;
1365 -- We should never get here, since we were called for some reason, and
1366 -- we should have found and eliminated at least one bad path.
1368 raise Program_Error
;
1369 end Diagnose_Elaboration_Problem
;
1371 --------------------
1372 -- Elab_All_Links --
1373 --------------------
1375 procedure Elab_All_Links
1378 Reason
: Succ_Reason
;
1382 if UNR
.Table
(Before
).Visited
then
1386 -- Build the direct link for Before
1388 UNR
.Table
(Before
).Visited
:= True;
1389 Build_Link
(Before
, After
, Reason
, Link
);
1391 -- Process all units with'ed by Before recursively
1393 for W
in Units
.Table
(Before
).First_With
..
1394 Units
.Table
(Before
).Last_With
1396 -- Skip if this with is an interface to a stand-alone library. Skip
1397 -- also if no ALI file for this WITH, happens for language defined
1398 -- generics while bootstrapping the compiler (see body of routine
1399 -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited with
1400 -- clause, which does not impose an elaboration link.
1402 if not Withs
.Table
(W
).SAL_Interface
1403 and then Withs
.Table
(W
).Afile
/= No_File
1404 and then not Withs
.Table
(W
).Limited_With
1407 Info
: constant Int
:=
1408 Get_Name_Table_Int
(Withs
.Table
(W
).Uname
);
1411 -- If the unit is unknown, for some unknown reason, fail
1412 -- graciously explaining that the unit is unknown. Without
1413 -- this check, gnatbind will crash in Unit_Id_Of.
1415 if Info
= 0 or else Unit_Id
(Info
) = No_Unit_Id
then
1418 Get_Name_String
(Withs
.Table
(W
).Uname
);
1419 Last_Withed
: Natural := Withed
'Last;
1422 (Units
.Table
(Before
).Uname
);
1423 Last_Withing
: Natural := Withing
'Last;
1424 Spec_Body
: String := " (Spec)";
1431 and then Withed
(Last_Withed
- 1) = '%'
1433 Last_Withed
:= Last_Withed
- 2;
1437 and then Withing
(Last_Withing
- 1) = '%'
1439 Last_Withing
:= Last_Withing
- 2;
1442 if Units
.Table
(Before
).Utype
= Is_Body
1443 or else Units
.Table
(Before
).Utype
= Is_Body_Only
1445 Spec_Body
:= " (Body)";
1449 ("could not find unit "
1450 & Withed
(Withed
'First .. Last_Withed
) & " needed by "
1451 & Withing
(Withing
'First .. Last_Withing
) & Spec_Body
);
1456 (Unit_Id_Of
(Withs
.Table
(W
).Uname
),
1459 Make_Elab_All_Entry
(Withs
.Table
(W
).Uname
, Link
));
1464 -- Process corresponding body, if there is one
1466 if Units
.Table
(Before
).Utype
= Is_Spec
then
1468 (Corresponding_Body
(Before
),
1471 (Units
.Table
(Corresponding_Body
(Before
)).Uname
, Link
));
1475 --------------------
1476 -- Elab_Error_Msg --
1477 --------------------
1479 procedure Elab_Error_Msg
(S
: Successor_Id
) is
1480 SL
: Successor_Link
renames Succ
.Table
(S
);
1483 -- Nothing to do if internal unit involved and no -da flag
1487 (Is_Internal_File_Name
(Units
.Table
(SL
.Before
).Sfile
)
1489 Is_Internal_File_Name
(Units
.Table
(SL
.After
).Sfile
))
1494 -- Here we want to generate output
1496 Error_Msg_Unit_1
:= Units
.Table
(SL
.Before
).Uname
;
1498 if SL
.Elab_Body
then
1499 Error_Msg_Unit_2
:= Units
.Table
(Corresponding_Body
(SL
.After
)).Uname
;
1501 Error_Msg_Unit_2
:= Units
.Table
(SL
.After
).Uname
;
1504 Error_Msg_Output
(" $ must be elaborated before $", Info
=> True);
1506 Error_Msg_Unit_1
:= Units
.Table
(SL
.Reason_Unit
).Uname
;
1511 (" reason: with clause",
1516 (" reason: forced by -f switch",
1521 (" reason: pragma Elaborate in unit $",
1526 (" reason: pragma Elaborate_All in unit $",
1529 when Elab_All_Desirable
=>
1531 (" reason: implicit Elaborate_All in unit $",
1535 (" recompile $ with -gnatel for full details",
1538 when Elab_Desirable
=>
1540 (" reason: implicit Elaborate in unit $",
1544 (" recompile $ with -gnatel for full details",
1549 (" reason: spec always elaborated before body",
1553 Write_Elab_All_Chain
(S
);
1555 if SL
.Elab_Body
then
1556 Error_Msg_Unit_1
:= Units
.Table
(SL
.Before
).Uname
;
1557 Error_Msg_Unit_2
:= Units
.Table
(SL
.After
).Uname
;
1559 (" $ must therefore be elaborated before $", True);
1561 Error_Msg_Unit_1
:= Units
.Table
(SL
.After
).Uname
;
1563 (" (because $ has a pragma Elaborate_Body)", True);
1566 if not Zero_Formatting
then
1571 ---------------------
1572 -- Find_Elab_Order --
1573 ---------------------
1575 procedure Find_Elab_Order
1576 (Elab_Order
: out Unit_Id_Table
;
1577 First_Main_Lib_File
: File_Name_Type
)
1579 function Num_Spec_Body_Pairs
(Order
: Unit_Id_Array
) return Nat
;
1580 -- Number of cases where the body of a unit immediately follows the
1581 -- corresponding spec. Such cases are good, because calls to that unit
1582 -- from outside can't get ABE.
1584 -------------------------
1585 -- Num_Spec_Body_Pairs --
1586 -------------------------
1588 function Num_Spec_Body_Pairs
(Order
: Unit_Id_Array
) return Nat
is
1592 for J
in Order
'First + 1 .. Order
'Last loop
1593 if Units
.Table
(Order
(J
- 1)).Utype
= Is_Spec
1594 and then Units
.Table
(Order
(J
)).Utype
= Is_Body
1595 and then Corresponding_Spec
(Order
(J
)) = Order
(J
- 1)
1597 Result
:= Result
+ 1;
1602 end Num_Spec_Body_Pairs
;
1606 Old_Elab_Order
: Unit_Id_Table
;
1608 -- Start of processing for Find_Elab_Order
1611 -- Output warning if -p used with no -gnatE units
1613 if Pessimistic_Elab_Order
1614 and not Dynamic_Elaboration_Checks_Specified
1616 Error_Msg
("?use of -p switch questionable");
1617 Error_Msg
("?since all units compiled with static elaboration model");
1620 if Do_New
and not Debug_Flag_Old
and not Debug_Flag_Older
then
1621 if Debug_Flag_V
then
1622 Write_Line
("Doing new...");
1627 Elab_New
.Find_Elab_Order
(Elab_Order
);
1630 -- Elab_New does not support the pessimistic order, so if that was
1631 -- requested, use the old results. Use Elab_Old if -dp or -do was
1632 -- selected. Elab_New does not yet give proper error messages for
1633 -- illegal Elaborate_Alls, so if there is one, run Elab_Old.
1636 or Pessimistic_Elab_Order
1641 if Debug_Flag_V
then
1642 Write_Line
("Doing old...");
1647 Elab_Old
.Find_Elab_Order
(Old_Elab_Order
);
1650 pragma Assert
(Elab_Cycle_Found
<= -- implies
1651 Diagnose_Elaboration_Problem_Called
);
1654 Old_Order
: Unit_Id_Array
renames
1655 Old_Elab_Order
.Table
(1 .. Last
(Old_Elab_Order
));
1657 if Do_Old
and Do_New
then
1659 New_Order
: Unit_Id_Array
renames
1660 Elab_Order
.Table
(1 .. Last
(Elab_Order
));
1661 Old_Pairs
: constant Nat
:= Num_Spec_Body_Pairs
(Old_Order
);
1662 New_Pairs
: constant Nat
:= Num_Spec_Body_Pairs
(New_Order
);
1665 Write_Line
(Get_Name_String
(First_Main_Lib_File
));
1667 pragma Assert
(Old_Order
'Length = New_Order
'Length);
1668 pragma Debug
(Validate
(Old_Order
, Doing_New
=> False));
1669 pragma Debug
(Validate
(New_Order
, Doing_New
=> True));
1671 -- Misc debug printouts that can be used for experimentation by
1672 -- changing the 'if's below.
1675 if New_Order
= Old_Order
then
1676 Write_Line
("Elab_New: same order.");
1678 Write_Line
("Elab_New: diff order.");
1682 if New_Order
/= Old_Order
and then False then
1683 Write_Line
("Elaboration orders differ:");
1685 (Old_Order
, Title
=> "OLD ELABORATION ORDER");
1687 (New_Order
, Title
=> "NEW ELABORATION ORDER");
1691 Write_Str
("Pairs: ");
1692 Write_Int
(Old_Pairs
);
1694 if Old_Pairs
= New_Pairs
then
1696 elsif Old_Pairs
< New_Pairs
then
1702 Write_Int
(New_Pairs
);
1706 if Old_Pairs
/= New_Pairs
and then False then
1707 Write_Str
("Pairs: ");
1708 Write_Int
(Old_Pairs
);
1710 if Old_Pairs
< New_Pairs
then
1716 Write_Int
(New_Pairs
);
1719 if Old_Pairs
/= New_Pairs
and then Debug_Flag_V
then
1721 (Old_Order
, Title
=> "OLD ELABORATION ORDER");
1723 (New_Order
, Title
=> "NEW ELABORATION ORDER");
1724 pragma Assert
(New_Pairs
>= Old_Pairs
);
1730 -- The Elab_New algorithm doesn't implement the -p switch, so if that
1731 -- was used, use the results from the old algorithm. Likewise if the
1732 -- user has requested the old algorithm.
1734 if Pessimistic_Elab_Order
or Debug_Flag_Old
or Debug_Flag_Older
then
1736 (Last
(Elab_Order
) = 0
1737 or else Last
(Elab_Order
) = Old_Order
'Last);
1740 Append_All
(Elab_Order
, Old_Order
);
1743 -- Now set the Elab_Positions in the Units table. It is important to
1744 -- do this late, in case we're running both Elab_New and Elab_Old.
1747 New_Order
: Unit_Id_Array
renames
1748 Elab_Order
.Table
(1 .. Last
(Elab_Order
));
1749 Units_Array
: Units
.Table_Type
renames
1750 Units
.Table
(Units
.First
.. Units
.Last
);
1752 for J
in New_Order
'Range loop
1754 (UNR
.Table
(New_Order
(J
)).Elab_Position
= J
);
1755 Units_Array
(New_Order
(J
)).Elab_Position
:= J
;
1758 if Errors_Detected
= 0 then
1760 -- Display elaboration order if -l was specified
1762 if Elab_Order_Output
then
1763 if Zero_Formatting
then
1764 Write_Elab_Order
(New_Order
, Title
=> "");
1767 (New_Order
, Title
=> "ELABORATION ORDER");
1771 -- Display list of sources in the closure (except predefined
1772 -- sources) if -R was used. Include predefined sources if -Ra
1775 if List_Closure
then
1776 Write_Closure
(New_Order
);
1781 end Find_Elab_Order
;
1783 ----------------------
1784 -- Force_Elab_Order --
1785 ----------------------
1787 procedure Force_Elab_Order
is
1789 -- There is a lot of fiddly string manipulation below, because we don't
1790 -- want to depend on misc utility packages like Ada.Characters.Handling.
1792 function Get_Line
return String;
1793 -- Read the next line from the file content read by Read_File. Strip
1794 -- all leading and trailing blanks. Convert "(spec)" or "(body)" to
1795 -- "%s"/"%b". Remove comments (Ada style; "--" to end of line).
1797 function Read_File
(Name
: String) return String_Ptr
;
1798 -- Read the entire contents of the named file
1800 subtype Header_Num
is Unit_Name_Type
'Base range 0 .. 2**16 - 1;
1801 type Line_Number
is new Nat
;
1802 No_Line_Number
: constant Line_Number
:= 0;
1803 Cur_Line_Number
: Line_Number
:= 0;
1804 -- Current line number in the Force_Elab_Order_File.
1805 -- Incremented by Get_Line. Used in error messages.
1807 function Hash
(N
: Unit_Name_Type
) return Header_Num
;
1809 package Name_Map
is new System
.HTable
.Simple_HTable
1810 (Header_Num
=> Header_Num
,
1811 Element
=> Line_Number
,
1812 No_Element
=> No_Line_Number
,
1813 Key
=> Unit_Name_Type
,
1816 -- Name_Map contains an entry for each file name seen, mapped to the
1817 -- line number where we saw it first. This is used to give an error for
1824 function Hash
(N
: Unit_Name_Type
) return Header_Num
is
1825 -- Name_Ids are already widely dispersed; no need for any actual
1826 -- hashing. Just subtract to make it zero based, and "mod" to
1827 -- bring it in range.
1829 return (N
- Unit_Name_Type
'First) mod (Header_Num
'Last + 1);
1836 function Read_File
(Name
: String) return String_Ptr
is
1838 -- All of the following calls should succeed, because we checked the
1839 -- file in Switch.B, but we double check and raise Program_Error on
1840 -- failure, just in case.
1842 F
: constant File_Descriptor
:= Open_Read
(Name
, Binary
);
1845 if F
= Invalid_FD
then
1846 raise Program_Error
;
1850 Len
: constant Natural := Natural (File_Length
(F
));
1851 Result
: constant String_Ptr
:= new String (1 .. Len
);
1852 Len_Read
: constant Natural :=
1853 Read
(F
, Result
(1)'Address, Len
);
1858 if Len_Read
/= Len
then
1859 raise Program_Error
;
1865 raise Program_Error
;
1872 Cur
: Positive := 1;
1873 S
: String_Ptr
:= Read_File
(Force_Elab_Order_File
.all);
1879 function Get_Line
return String is
1880 First
: Positive := Cur
;
1884 Cur_Line_Number
:= Cur_Line_Number
+ 1;
1886 -- Skip to end of line
1889 and then S
(Cur
) /= ASCII
.LF
1890 and then S
(Cur
) /= ASCII
.CR
1895 -- Strip leading blanks
1897 while First
<= S
'Last and then S
(First
) = ' ' loop
1901 -- Strip trailing blanks and comment
1905 for J
in First
.. Last
- 1 loop
1906 if S
(J
.. J
+ 1) = "--" then
1912 while Last
>= First
and then S
(Last
) = ' ' loop
1916 -- Convert "(spec)" or "(body)" to "%s"/"%b", strip trailing blanks
1920 Body_String
: constant String := "(body)";
1921 BL
: constant Positive := Body_String
'Length;
1922 Spec_String
: constant String := "(spec)";
1923 SL
: constant Positive := Spec_String
'Length;
1925 Line
: String renames S
(First
.. Last
);
1927 Is_Body
: Boolean := False;
1928 Is_Spec
: Boolean := False;
1931 if Line
'Length >= SL
1932 and then Line
(Last
- SL
+ 1 .. Last
) = Spec_String
1936 elsif Line
'Length >= BL
1937 and then Line
(Last
- BL
+ 1 .. Last
) = Body_String
1943 while Last
>= First
and then S
(Last
) = ' ' loop
1947 -- Skip past LF or CR/LF
1949 if Cur
<= S
'Last and then S
(Cur
) = ASCII
.CR
then
1953 if Cur
<= S
'Last and then S
(Cur
) = ASCII
.LF
then
1958 return Line
(First
.. Last
) & "%s";
1960 return Line
(First
.. Last
) & "%b";
1969 Empty_Name
: constant Unit_Name_Type
:= Name_Find
("");
1970 Prev_Unit
: Unit_Id
:= No_Unit_Id
;
1972 -- Start of processing for Force_Elab_Order
1975 -- Loop through the file content, and build a dependency link for each
1976 -- pair of lines. Ignore lines that should be ignored.
1978 while Cur
<= S
'Last loop
1980 Uname
: constant Unit_Name_Type
:= Name_Find
(Get_Line
);
1981 Error
: Boolean := False;
1984 if Uname
= Empty_Name
then
1985 null; -- silently skip blank lines
1988 Dup
: constant Line_Number
:= Name_Map
.Get
(Uname
);
1990 if Dup
= No_Line_Number
then
1991 Name_Map
.Set
(Uname
, Cur_Line_Number
);
1993 -- We don't need to give the "not present" message in
1994 -- the case of "duplicate unit", because we would have
1995 -- already given the "not present" message on the
1996 -- first occurrence.
1998 if Get_Name_Table_Int
(Uname
) = 0
1999 or else Unit_Id
(Get_Name_Table_Int
(Uname
)) =
2005 ("""" & Get_Name_String
(Uname
)
2006 & """: not present; ignored");
2013 Error_Msg_Nat_1
:= Nat
(Cur_Line_Number
);
2014 Error_Msg_Unit_1
:= Uname
;
2015 Error_Msg_Nat_2
:= Nat
(Dup
);
2017 (Force_Elab_Order_File
.all
2018 & ":#: duplicate unit name $ from line #");
2025 Cur_Unit
: constant Unit_Id
:= Unit_Id_Of
(Uname
);
2027 if Is_Internal_File_Name
2028 (Units
.Table
(Cur_Unit
).Sfile
)
2032 ("""" & Get_Name_String
(Uname
)
2033 & """: predefined unit ignored");
2037 if Prev_Unit
/= No_Unit_Id
then
2039 Write_Unit_Name
(Units
.Table
(Prev_Unit
).Uname
);
2040 Write_Str
(" <-- ");
2041 Write_Unit_Name
(Units
.Table
(Cur_Unit
).Uname
);
2046 (Before
=> Prev_Unit
,
2051 Prev_Unit
:= Cur_Unit
;
2060 end Force_Elab_Order
;
2062 -------------------------
2063 -- Gather_Dependencies --
2064 -------------------------
2066 procedure Gather_Dependencies
is
2067 Withed_Unit
: Unit_Id
;
2070 -- Loop through all units
2072 for U
in Units
.First
.. Units
.Last
loop
2075 -- If this is not an interface to a stand-alone library and there is
2076 -- a body and a spec, then spec must be elaborated first. Note that
2077 -- the corresponding spec immediately follows the body.
2079 if not Units
.Table
(U
).SAL_Interface
2080 and then Units
.Table
(U
).Utype
= Is_Body
2082 Build_Link
(Corresponding_Spec
(U
), U
, Spec_First
);
2085 -- If this unit is not an interface to a stand-alone library, process
2086 -- WITH references for this unit ignoring interfaces to stand-alone
2089 if not Units
.Table
(U
).SAL_Interface
then
2090 for W
in Units
.Table
(U
).First_With
..
2091 Units
.Table
(U
).Last_With
2093 if Withs
.Table
(W
).Sfile
/= No_File
2094 and then (not Withs
.Table
(W
).SAL_Interface
)
2096 -- Check for special case of withing a unit that does not
2097 -- exist any more. If the unit was completely missing we
2098 -- would already have detected this, but a nasty case arises
2099 -- when we have a subprogram body with no spec, and some
2100 -- obsolete unit with's a previous (now disappeared) spec.
2102 if Get_Name_Table_Int
(Withs
.Table
(W
).Uname
) = 0 then
2104 Error_Msg_File_1
:= Units
.Table
(U
).Sfile
;
2105 Error_Msg_Unit_1
:= Withs
.Table
(W
).Uname
;
2106 Error_Msg
("{ depends on $ which no longer exists");
2112 Withed_Unit
:= Unit_Id_Of
(Withs
.Table
(W
).Uname
);
2114 -- Pragma Elaborate_All case, for this we use the recursive
2115 -- Elab_All_Links procedure to establish the links.
2117 -- Elab_New ignores Elaborate_All and Elab_All_Desirable,
2118 -- except for error messages.
2120 if Withs
.Table
(W
).Elaborate_All
and then not Doing_New
then
2122 -- Reset flags used to stop multiple visits to a given
2125 for Uref
in UNR
.First
.. UNR
.Last
loop
2126 UNR
.Table
(Uref
).Visited
:= False;
2129 -- Now establish all the links we need
2132 (Withed_Unit
, U
, Elab_All
,
2134 (Withs
.Table
(W
).Uname
, No_Elab_All_Link
));
2136 -- Elaborate_All_Desirable case, for this we establish the
2137 -- same links as above, but with a different reason.
2139 elsif Withs
.Table
(W
).Elab_All_Desirable
2140 and then not Doing_New
2142 -- Reset flags used to stop multiple visits to a given
2145 for Uref
in UNR
.First
.. UNR
.Last
loop
2146 UNR
.Table
(Uref
).Visited
:= False;
2149 -- Now establish all the links we need
2152 (Withed_Unit
, U
, Elab_All_Desirable
,
2154 (Withs
.Table
(W
).Uname
, No_Elab_All_Link
));
2156 -- Pragma Elaborate case. We must build a link for the
2157 -- withed unit itself, and also the corresponding body if
2160 -- However, skip this processing if there is no ALI file for
2161 -- the WITH entry, because this means it is a generic (even
2162 -- when we fix the generics so that an ALI file is present,
2163 -- we probably still will have no ALI file for unchecked and
2164 -- other special cases).
2166 elsif Withs
.Table
(W
).Elaborate
2167 and then Withs
.Table
(W
).Afile
/= No_File
2169 Build_Link
(Withed_Unit
, U
, Withed
);
2171 if Units
.Table
(Withed_Unit
).Utype
= Is_Spec
then
2173 (Corresponding_Body
(Withed_Unit
), U
, Elab
);
2176 -- Elaborate_Desirable case, for this we establish the same
2177 -- links as above, but with a different reason.
2179 elsif Withs
.Table
(W
).Elab_Desirable
then
2180 Build_Link
(Withed_Unit
, U
, Withed
);
2182 if Units
.Table
(Withed_Unit
).Utype
= Is_Spec
then
2184 (Corresponding_Body
(Withed_Unit
),
2188 -- A limited_with does not establish an elaboration
2189 -- dependence (that's the whole point).
2191 elsif Withs
.Table
(W
).Limited_With
then
2194 -- Case of normal WITH with no elaboration pragmas, just
2195 -- build the single link to the directly referenced unit
2198 Build_Link
(Withed_Unit
, U
, Withed
);
2208 -- If -f<elab_order> switch was given, take into account dependences
2209 -- specified in the file <elab_order>.
2211 if Force_Elab_Order_File
/= null then
2215 -- Output elaboration dependencies if option is set
2217 if Elab_Dependency_Output
or Debug_Flag_E
then
2222 end Gather_Dependencies
;
2231 Num_Left
:= Int
(Units
.Last
- Units
.First
+ 1);
2233 Elab_All_Entries
.Init
;
2236 -- Initialize unit table for elaboration control
2238 for U
in Units
.First
.. Units
.Last
loop
2240 ((Successors
=> No_Successor
,
2242 Nextnp
=> No_Unit_Id
,
2245 SCC_Root
=> No_Unit_Id
,
2248 Validate_Seen
=> False));
2256 function Is_Body_Unit
(U
: Unit_Id
) return Boolean is
2259 Units
.Table
(U
).Utype
= Is_Body
2260 or else Units
.Table
(U
).Utype
= Is_Body_Only
;
2263 -----------------------------
2264 -- Is_Pure_Or_Preelab_Unit --
2265 -----------------------------
2267 function Is_Pure_Or_Preelab_Unit
(U
: Unit_Id
) return Boolean is
2269 -- If we have a body with separate spec, test flags on the spec
2271 if Units
.Table
(U
).Utype
= Is_Body
then
2273 Units
.Table
(Corresponding_Spec
(U
)).Preelab
2274 or else Units
.Table
(Corresponding_Spec
(U
)).Pure
;
2276 -- Otherwise we have a spec or body acting as spec, test flags on unit
2279 return Units
.Table
(U
).Preelab
or else Units
.Table
(U
).Pure
;
2281 end Is_Pure_Or_Preelab_Unit
;
2283 ---------------------
2284 -- Is_Waiting_Body --
2285 ---------------------
2287 function Is_Waiting_Body
(U
: Unit_Id
) return Boolean is
2290 Units
.Table
(U
).Utype
= Is_Body
2291 and then UNR
.Table
(Corresponding_Spec
(U
)).Elab_Position
/= 0;
2292 end Is_Waiting_Body
;
2294 -------------------------
2295 -- Make_Elab_All_Entry --
2296 -------------------------
2298 function Make_Elab_All_Entry
2299 (Unam
: Unit_Name_Type
;
2300 Link
: Elab_All_Id
) return Elab_All_Id
2303 Elab_All_Entries
.Append
((Needed_By
=> Unam
, Next_Elab
=> Link
));
2304 return Elab_All_Entries
.Last
;
2305 end Make_Elab_All_Entry
;
2311 function Unit_Id_Of
(Uname
: Unit_Name_Type
) return Unit_Id
is
2312 Info
: constant Int
:= Get_Name_Table_Int
(Uname
);
2315 pragma Assert
(Info
/= 0 and then Unit_Id
(Info
) /= No_Unit_Id
);
2316 return Unit_Id
(Info
);
2323 procedure Validate
(Order
: Unit_Id_Array
; Doing_New
: Boolean) is
2324 Cur_SCC
: Unit_Id
:= No_Unit_Id
;
2325 OK
: Boolean := True;
2326 Msg
: String := "Old: ";
2333 -- For each unit, assert that its successors are elaborated after it
2335 for J
in Order
'Range loop
2337 U
: constant Unit_Id
:= Order
(J
);
2338 S
: Successor_Id
:= UNR
.Table
(U
).Successors
;
2341 while S
/= No_Successor
loop
2342 if UNR
.Table
(Succ
.Table
(S
).After
).Elab_Position
<=
2343 UNR
.Table
(U
).Elab_Position
2346 Write_Line
(Msg
& " elab order failed");
2349 S
:= Succ
.Table
(S
).Next
;
2354 -- An SCC of size 2 units necessarily consists of a spec and the
2355 -- corresponding body. Assert that the body is elaborated immediately
2356 -- after the spec, with nothing in between. (We only have SCCs in the
2360 for J
in Order
'Range loop
2362 U
: constant Unit_Id
:= Order
(J
);
2365 if Nodes
(U
)'Length = 2 then
2366 if Units
.Table
(U
).Utype
= Is_Spec
then
2367 if Order
(J
+ 1) /= Corresponding_Body
(U
) then
2369 Write_Line
(Msg
& "Bad spec with SCC of size 2:");
2370 Write_SCC
(SCC
(U
));
2374 if Units
.Table
(U
).Utype
= Is_Body
then
2375 if Order
(J
- 1) /= Corresponding_Spec
(U
) then
2377 Write_Line
(Msg
& "Bad body with SCC of size 2:");
2378 Write_SCC
(SCC
(U
));
2385 -- Assert that all units of an SCC are elaborated together, with no
2386 -- units from other SCCs in between. The above spec/body case is a
2387 -- special case of this general rule.
2389 for J
in Order
'Range loop
2391 U
: constant Unit_Id
:= Order
(J
);
2394 if SCC
(U
) /= Cur_SCC
then
2396 if UNR
.Table
(Cur_SCC
).Validate_Seen
then
2398 Write_Line
(Msg
& "SCC not elaborated together:");
2399 Write_SCC
(Cur_SCC
);
2402 UNR
.Table
(Cur_SCC
).Validate_Seen
:= True;
2415 procedure Write_Closure
(Order
: Unit_Id_Array
) is
2416 package Closure_Sources
is new Table
.Table
2417 (Table_Component_Type
=> File_Name_Type
,
2418 Table_Index_Type
=> Natural,
2419 Table_Low_Bound
=> 1,
2420 Table_Initial
=> 10,
2421 Table_Increment
=> 100,
2422 Table_Name
=> "Gnatbind.Closure_Sources");
2423 -- Table to record the sources in the closure, to avoid duplications
2425 function Put_In_Sources
(S
: File_Name_Type
) return Boolean;
2426 -- Check if S is already in table Sources and put in Sources if it is
2427 -- not. Return False if the source is already in Sources, and True if
2430 --------------------
2431 -- Put_In_Sources --
2432 --------------------
2434 function Put_In_Sources
(S
: File_Name_Type
) return Boolean is
2436 for J
in 1 .. Closure_Sources
.Last
loop
2437 if Closure_Sources
.Table
(J
) = S
then
2442 Closure_Sources
.Append
(S
);
2448 Source
: File_Name_Type
;
2450 -- Start of processing for Write_Closure
2453 Closure_Sources
.Init
;
2455 if not Zero_Formatting
then
2457 Write_Line
("REFERENCED SOURCES");
2460 for J
in reverse Order
'Range loop
2461 Source
:= Units
.Table
(Order
(J
)).Sfile
;
2463 -- Do not include same source more than once
2465 if Put_In_Sources
(Source
)
2467 -- Do not include run-time units unless -Ra switch set
2469 and then (List_Closure_All
2470 or else not Is_Internal_File_Name
(Source
))
2472 if not Zero_Formatting
then
2476 Write_Line
(Get_Name_String
(Source
));
2480 -- Subunits do not appear in the elaboration table because they are
2481 -- subsumed by their parent units, but we need to list them for other
2482 -- tools. For now they are listed after other files, rather than right
2483 -- after their parent, since there is no easy link between the
2484 -- elaboration table and the ALIs table ??? As subunits may appear
2485 -- repeatedly in the list, if the parent unit appears in the context of
2486 -- several units in the closure, duplicates are suppressed.
2488 for J
in Sdep
.First
.. Sdep
.Last
loop
2489 Source
:= Sdep
.Table
(J
).Sfile
;
2491 if Sdep
.Table
(J
).Subunit_Name
/= No_Name
2492 and then Put_In_Sources
(Source
)
2493 and then not Is_Internal_File_Name
(Source
)
2495 if not Zero_Formatting
then
2499 Write_Line
(Get_Name_String
(Source
));
2503 if not Zero_Formatting
then
2508 ------------------------
2509 -- Write_Dependencies --
2510 ------------------------
2512 procedure Write_Dependencies
is
2514 if not Zero_Formatting
then
2516 Write_Line
(" ELABORATION ORDER DEPENDENCIES");
2520 Info_Prefix_Suppress
:= True;
2522 for S
in Succ_First
.. Succ
.Last
loop
2526 Info_Prefix_Suppress
:= False;
2528 if not Zero_Formatting
then
2531 end Write_Dependencies
;
2533 --------------------------
2534 -- Write_Elab_All_Chain --
2535 --------------------------
2537 procedure Write_Elab_All_Chain
(S
: Successor_Id
) is
2538 ST
: constant Successor_Link
:= Succ
.Table
(S
);
2539 After
: constant Unit_Name_Type
:= Units
.Table
(ST
.After
).Uname
;
2542 Nam
: Unit_Name_Type
;
2544 First_Name
: Boolean := True;
2547 if ST
.Reason
in Elab_All
.. Elab_All_Desirable
then
2548 L
:= ST
.Elab_All_Link
;
2549 while L
/= No_Elab_All_Link
loop
2550 Nam
:= Elab_All_Entries
.Table
(L
).Needed_By
;
2551 Error_Msg_Unit_1
:= Nam
;
2552 Error_Msg_Output
(" $", Info
=> True);
2554 Get_Name_String
(Nam
);
2556 if Name_Buffer
(Name_Len
) = 'b' then
2559 (" must be elaborated along with its spec:",
2564 (" which must be elaborated along with its "
2577 (" which is withed by:",
2582 First_Name
:= False;
2584 L
:= Elab_All_Entries
.Table
(L
).Next_Elab
;
2587 Error_Msg_Unit_1
:= After
;
2588 Error_Msg_Output
(" $", Info
=> True);
2590 end Write_Elab_All_Chain
;
2592 ----------------------
2593 -- Write_Elab_Order --
2594 ----------------------
2596 procedure Write_Elab_Order
2597 (Order
: Unit_Id_Array
; Title
: String)
2605 for J
in Order
'Range loop
2606 if not Units
.Table
(Order
(J
)).SAL_Interface
then
2607 if not Zero_Formatting
then
2611 Write_Unit_Name
(Units
.Table
(Order
(J
)).Uname
);
2619 end Write_Elab_Order
;
2625 package body Elab_New
is
2631 type Node_Array
is array (Pos
range <>) of Node
;
2632 with function Successors
(N
: Node
) return Node_Array
;
2633 with procedure Create_SCC
(Root
: Node
; Nodes
: Node_Array
);
2635 procedure Compute_Strongly_Connected_Components
;
2636 -- Compute SCCs for a directed graph. The nodes in the graph are all
2637 -- values of type Node in the range First_Node .. Last_Node.
2638 -- Successors(N) returns the nodes pointed to by the edges emanating
2639 -- from N. Create_SCC is a callback that is called once for each SCC,
2640 -- passing in the Root node for that SCC (which is an arbitrary node in
2641 -- the SCC used as a representative of that SCC), and the set of Nodes
2644 -- This is generic, in case we want to use it elsewhere; then we could
2645 -- move this into a separate library unit. Unfortunately, it's not as
2646 -- generic as one might like. Ideally, we would have "type Node is
2647 -- private;", and pass in iterators to iterate over all nodes, and over
2648 -- the successors of a given node. However, that leads to using advanced
2649 -- features of Ada that are not allowed in the compiler and binder for
2650 -- bootstrapping reasons. It also leads to trampolines, which are not
2651 -- allowed in the compiler and binder. Restricting Node to be discrete
2652 -- allows us to iterate over all nodes with a 'for' loop, and allows us
2653 -- to attach temporary information to nodes by having an array indexed
2656 procedure Compute_Unit_SCCs
;
2657 -- Use the above generic procedure to compute the SCCs for the graph of
2658 -- units. Store in each Unit_Node_Record the SCC_Root and Nodes
2659 -- components. Also initialize the SCC_Num_Pred components.
2661 procedure Find_Elab_All_Errors
;
2662 -- Generate an error for illegal Elaborate_All pragmas (explicit or
2663 -- implicit). A pragma Elaborate_All (Y) on unit X is legal if and only
2664 -- if X and Y are in different SCCs.
2666 -------------------------------------------
2667 -- Compute_Strongly_Connected_Components --
2668 -------------------------------------------
2670 procedure Compute_Strongly_Connected_Components
is
2672 -- This uses Tarjan's algorithm for finding SCCs. Comments here are
2673 -- intended to tell what it does, but if you want to know how it
2674 -- works, you have to look it up. Please do not modify this code
2675 -- without reading up on Tarjan's algorithm.
2677 subtype Node_Index
is Nat
;
2678 No_Index
: constant Node_Index
:= 0;
2680 Num_Nodes
: constant Nat
:=
2681 Node
'Pos (Last_Node
) - Node
'Pos (First_Node
) + 1;
2682 Stack
: Node_Array
(1 .. Num_Nodes
);
2683 Top
: Node_Index
:= 0;
2684 -- Stack of nodes, pushed when first visited. All nodes of an SCC are
2685 -- popped at once when the SCC is found.
2687 subtype Valid_Node
is Node
range First_Node
.. Last_Node
;
2688 Node_Indices
: array (Valid_Node
) of Node_Index
:=
2689 (others => No_Index
);
2690 -- Each node has an "index", which is the sequential number in the
2691 -- order in which they are visited in the recursive walk. No_Index
2692 -- means "not yet visited"; we want to avoid walking any node more
2695 Index
: Node_Index
:= 1;
2696 -- Next value to be assigned to a node index
2698 Low_Links
: array (Valid_Node
) of Node_Index
;
2699 -- Low_Links (N) is the smallest index of nodes reachable from N
2701 On_Stack
: array (Valid_Node
) of Boolean := (others => False);
2702 -- True if the node is currently on the stack
2704 procedure Walk
(N
: Valid_Node
);
2705 -- Recursive depth-first graph walk, with the node index used to
2706 -- avoid visiting a node more than once.
2712 procedure Walk
(N
: Valid_Node
) is
2713 Stack_Position_Of_N
: constant Pos
:= Top
+ 1;
2714 S
: constant Node_Array
:= Successors
(N
);
2717 -- Assign the index and low link, increment Index for next call to
2720 Node_Indices
(N
) := Index
;
2721 Low_Links
(N
) := Index
;
2724 -- Push it on the stack:
2726 Top
:= Stack_Position_Of_N
;
2728 On_Stack
(N
) := True;
2730 -- Walk not-yet-visited subnodes, and update low link for visited
2731 -- ones as appropriate.
2733 for J
in S
'Range loop
2734 if Node_Indices
(S
(J
)) = No_Index
then
2737 Node_Index
'Min (Low_Links
(N
), Low_Links
(S
(J
)));
2738 elsif On_Stack
(S
(J
)) then
2740 Node_Index
'Min (Low_Links
(N
), Node_Indices
(S
(J
)));
2744 -- If the index is (still) equal to the low link, we've found an
2745 -- SCC. Pop the whole SCC off the stack, and call Create_SCC.
2747 if Low_Links
(N
) = Node_Indices
(N
) then
2749 SCC
: Node_Array
renames
2750 Stack
(Stack_Position_Of_N
.. Top
);
2751 pragma Assert
(SCC
'Length >= 1);
2752 pragma Assert
(SCC
(SCC
'First) = N
);
2755 for J
in SCC
'Range loop
2756 On_Stack
(SCC
(J
)) := False;
2759 Create_SCC
(Root
=> N
, Nodes
=> SCC
);
2760 pragma Assert
(Top
- SCC
'Length = Stack_Position_Of_N
- 1);
2761 Top
:= Stack_Position_Of_N
- 1; -- pop all
2766 -- Start of processing for Compute_Strongly_Connected_Components
2769 -- Walk all the nodes that have not yet been walked
2771 for N
in Valid_Node
loop
2772 if Node_Indices
(N
) = No_Index
then
2776 end Compute_Strongly_Connected_Components
;
2778 -----------------------
2779 -- Compute_Unit_SCCs --
2780 -----------------------
2782 procedure Compute_Unit_SCCs
is
2783 function Successors
(U
: Unit_Id
) return Unit_Id_Array
;
2784 -- Return all the units that must be elaborated after U. In addition,
2785 -- if U is a body, include the corresponding spec; this ensures that
2786 -- a spec/body pair are always in the same SCC.
2788 procedure Create_SCC
(Root
: Unit_Id
; Nodes
: Unit_Id_Array
);
2789 -- Set Nodes of the Root, and set SCC_Root of all the Nodes
2791 procedure Init_SCC_Num_Pred
(U
: Unit_Id
);
2792 -- Initialize the SCC_Num_Pred fields, so that the root of each SCC
2793 -- has a count of the number of successors of all the units in the
2794 -- SCC, but only for successors outside the SCC.
2796 procedure Compute_SCCs
is new Compute_Strongly_Connected_Components
2798 First_Node
=> Units
.First
,
2799 Last_Node
=> Units
.Last
,
2800 Node_Array
=> Unit_Id_Array
,
2801 Successors
=> Successors
,
2802 Create_SCC
=> Create_SCC
);
2808 procedure Create_SCC
(Root
: Unit_Id
; Nodes
: Unit_Id_Array
) is
2810 if Debug_Flag_V
then
2811 Write_Str
("Root = ");
2812 Write_Int
(Int
(Root
));
2814 Write_Unit_Name
(Units
.Table
(Root
).Uname
);
2816 Write_Int
(Nodes
'Length);
2817 Write_Line
(" units:");
2819 for J
in Nodes
'Range loop
2821 Write_Int
(Int
(Nodes
(J
)));
2823 Write_Unit_Name
(Units
.Table
(Nodes
(J
)).Uname
);
2828 pragma Assert
(Nodes
(Nodes
'First) = Root
);
2829 pragma Assert
(UNR
.Table
(Root
).Nodes
= null);
2830 UNR
.Table
(Root
).Nodes
:= new Unit_Id_Array
'(Nodes);
2832 for J in Nodes'Range loop
2833 pragma Assert (SCC (Nodes (J)) = No_Unit_Id);
2834 UNR.Table (Nodes (J)).SCC_Root := Root;
2842 function Successors (U : Unit_Id) return Unit_Id_Array is
2843 S : Successor_Id := UNR.Table (U).Successors;
2844 Tab : Unit_Id_Table;
2847 -- Pretend that a spec is a successor of its body (even though it
2848 -- isn't), just so both get included.
2850 if Units.Table (U).Utype = Is_Body then
2851 Append (Tab, Corresponding_Spec (U));
2854 -- Now include the real successors
2856 while S /= No_Successor loop
2857 pragma Assert (Succ.Table (S).Before = U);
2858 Append (Tab, Succ.Table (S).After);
2859 S := Succ.Table (S).Next;
2863 Result : constant Unit_Id_Array := Tab.Table (1 .. Last (Tab));
2871 -----------------------
2872 -- Init_SCC_Num_Pred --
2873 -----------------------
2875 procedure Init_SCC_Num_Pred (U : Unit_Id) is
2877 if UNR.Table (U).Visited then
2881 UNR.Table (U).Visited := True;
2884 S : Successor_Id := UNR.Table (U).Successors;
2887 while S /= No_Successor loop
2888 pragma Assert (Succ.Table (S).Before = U);
2889 Init_SCC_Num_Pred (Succ.Table (S).After);
2891 if SCC (U) /= SCC (Succ.Table (S).After) then
2892 UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred :=
2893 UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred + 1;
2896 S := Succ.Table (S).Next;
2899 end Init_SCC_Num_Pred;
2901 -- Start of processing for Compute_Unit_SCCs
2906 for Uref in UNR.First .. UNR.Last loop
2907 pragma Assert (not UNR.Table (Uref).Visited);
2911 for Uref in UNR.First .. UNR.Last loop
2912 Init_SCC_Num_Pred (Uref);
2915 -- Assert that SCC_Root of all units has been set to a valid unit,
2916 -- and that SCC_Num_Pred has not been modified in non-root units.
2918 for Uref in UNR.First .. UNR.Last loop
2919 pragma Assert (UNR.Table (Uref).SCC_Root /= No_Unit_Id);
2920 pragma Assert (UNR.Table (Uref).SCC_Root in UNR.First .. UNR.Last);
2922 if SCC (Uref) /= Uref then
2923 pragma Assert (UNR.Table (Uref).SCC_Num_Pred = 0);
2927 end Compute_Unit_SCCs;
2929 --------------------------
2930 -- Find_Elab_All_Errors --
2931 --------------------------
2933 procedure Find_Elab_All_Errors is
2934 Withed_Unit : Unit_Id;
2937 for U in Units.First .. Units.Last loop
2939 -- If this unit is not an interface to a stand-alone library,
2940 -- process WITH references for this unit ignoring interfaces to
2941 -- stand-alone libraries.
2943 if not Units.Table (U).SAL_Interface then
2944 for W in Units.Table (U).First_With ..
2945 Units.Table (U).Last_With
2947 if Withs.Table (W).Sfile /= No_File
2948 and then (not Withs.Table (W).SAL_Interface)
2950 -- Check for special case of withing a unit that does not
2953 if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then
2957 Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname);
2959 -- If it's Elaborate_All or Elab_All_Desirable, check
2960 -- that the withER and withEE are not in the same SCC.
2962 if Withs.Table (W).Elaborate_All
2963 or else Withs.Table (W).Elab_All_Desirable
2965 if SCC (U) = SCC (Withed_Unit) then
2966 Elab_Cycle_Found := True; -- ???
2968 -- We could probably give better error messages
2969 -- than Elab_Old here, but for now, to avoid
2970 -- disruption, we don't give any error here.
2971 -- Instead, we set the Elab_Cycle_Found flag above,
2972 -- and then run the Elab_Old algorithm to issue the
2973 -- error message. Ideally, we would like to print
2974 -- multiple errors rather than stopping after the
2979 ("illegal pragma Elaborate_All",
2991 end Find_Elab_All_Errors;
2993 ---------------------
2994 -- Find_Elab_Order --
2995 ---------------------
2997 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
2998 Best_So_Far : Unit_Id;
3002 -- Gather dependencies and output them if option set
3004 Gather_Dependencies;
3008 -- Initialize the no-predecessor list
3010 No_Pred := No_Unit_Id;
3011 for U in UNR.First .. UNR.Last loop
3012 if UNR.Table (U).Num_Pred = 0 then
3013 UNR.Table (U).Nextnp := No_Pred;
3018 -- OK, now we determine the elaboration order proper. All we do is to
3019 -- select the best choice from the no-predecessor list until all the
3020 -- nodes have been chosen.
3023 if Debug_Flag_N then
3024 Write_Line ("Outer loop");
3027 -- If there are no nodes with predecessors, then either we are
3028 -- done, as indicated by Num_Left being set to zero, or we have
3029 -- a circularity. In the latter case, diagnose the circularity,
3030 -- removing it from the graph and continue.
3031 -- ????But Diagnose_Elaboration_Problem always raises an
3032 -- exception, so the loop never goes around more than once.
3034 Get_No_Pred : while No_Pred = No_Unit_Id loop
3035 exit Outer when Num_Left < 1;
3036 Diagnose_Elaboration_Problem (Elab_Order);
3037 end loop Get_No_Pred;
3040 Best_So_Far := No_Unit_Id;
3042 -- Loop to choose best entry in No_Pred list
3044 No_Pred_Search : loop
3045 if Debug_Flag_N then
3046 Write_Str (" considering choice of ");
3047 Write_Unit_Name (Units.Table (U).Uname);
3050 if Units.Table (U).Elaborate_Body then
3052 (" Elaborate_Body = True, Num_Pred for body = ");
3054 (UNR.Table (Corresponding_Body (U)).Num_Pred);
3057 (" Elaborate_Body = False");
3063 -- Don't even consider units whose SCC is not ready. This
3064 -- ensures that all units of an SCC will be elaborated
3065 -- together, with no other units in between.
3067 if SCC_Num_Pred (U) = 0
3068 and then Better_Choice (U, Best_So_Far)
3070 if Debug_Flag_N then
3071 Write_Line (" tentatively chosen (best so far)");
3076 if Debug_Flag_N then
3077 Write_Line (" SCC not ready");
3081 U := UNR.Table (U).Nextnp;
3082 exit No_Pred_Search when U = No_Unit_Id;
3083 end loop No_Pred_Search;
3085 -- If there are no units on the No_Pred list whose SCC is ready,
3086 -- there must be a cycle. Defer to Elab_Old to print an error
3089 if Best_So_Far = No_Unit_Id then
3090 Elab_Cycle_Found := True;
3094 -- Choose the best candidate found
3096 Choose (Elab_Order, Best_So_Far, " [Best_So_Far]");
3098 -- If it's a spec with a body, and the body is not yet chosen,
3099 -- choose the body if possible. The case where the body is
3100 -- already chosen is Elaborate_Body; the above call to Choose
3101 -- the spec will also Choose the body.
3103 if Units.Table (Best_So_Far).Utype = Is_Spec
3105 (Corresponding_Body (Best_So_Far)).Elab_Position = 0
3108 Choose_The_Body : constant Boolean :=
3109 UNR.Table (Corresponding_Body
3110 (Best_So_Far)).Num_Pred = 0;
3113 if Debug_Flag_B then
3114 Write_Str ("Can we choose the body?... ");
3116 if Choose_The_Body then
3117 Write_Line ("Yes!");
3123 if Choose_The_Body then
3125 (Elab_Order => Elab_Order,
3126 Chosen => Corresponding_Body (Best_So_Far),
3132 -- Finally, choose all the rest of the units in the same SCC as
3133 -- Best_So_Far. If it hasn't been chosen (Elab_Position = 0), and
3134 -- it's ready to be chosen (Num_Pred = 0), then we can choose it.
3138 Chose_One_Or_More : Boolean := False;
3139 SCC : Unit_Id_Array renames Nodes (Best_So_Far).all;
3142 for J in SCC'Range loop
3143 if UNR.Table (SCC (J)).Elab_Position = 0
3144 and then UNR.Table (SCC (J)).Num_Pred = 0
3146 Chose_One_Or_More := True;
3147 Choose (Elab_Order, SCC (J), " [same SCC]");
3151 exit when not Chose_One_Or_More;
3156 Find_Elab_All_Errors;
3157 end Find_Elab_Order;
3163 function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr is
3165 return UNR.Table (SCC (U)).Nodes;
3172 function SCC (U : Unit_Id) return Unit_Id is
3174 return UNR.Table (U).SCC_Root;
3181 function SCC_Num_Pred (U : Unit_Id) return Int is
3183 return UNR.Table (SCC (U)).SCC_Num_Pred;
3190 procedure Write_SCC (U : Unit_Id) is
3191 pragma Assert (SCC (U) = U);
3193 for J in Nodes (U)'Range loop
3194 Write_Int (UNR.Table (Nodes (U) (J)).Elab_Position);
3196 Write_Unit_Name (Units.Table (Nodes (U) (J)).Uname);
3209 package body Elab_Old is
3211 ---------------------
3212 -- Find_Elab_Order --
3213 ---------------------
3215 procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
3216 Best_So_Far : Unit_Id;
3220 -- Gather dependencies and output them if option set
3222 Gather_Dependencies;
3224 -- Initialize the no-predecessor list
3226 No_Pred := No_Unit_Id;
3227 for U in UNR.First .. UNR.Last loop
3228 if UNR.Table (U).Num_Pred = 0 then
3229 UNR.Table (U).Nextnp := No_Pred;
3234 -- OK, now we determine the elaboration order proper. All we do is to
3235 -- select the best choice from the no-predecessor list until all the
3236 -- nodes have been chosen.
3240 -- If there are no nodes with predecessors, then either we are
3241 -- done, as indicated by Num_Left being set to zero, or we have
3242 -- a circularity. In the latter case, diagnose the circularity,
3243 -- removing it from the graph and continue.
3244 -- ????But Diagnose_Elaboration_Problem always raises an
3245 -- exception, so the loop never goes around more than once.
3247 Get_No_Pred : while No_Pred = No_Unit_Id loop
3248 exit Outer when Num_Left < 1;
3249 Diagnose_Elaboration_Problem (Elab_Order);
3250 end loop Get_No_Pred;
3253 Best_So_Far := No_Unit_Id;
3255 -- Loop to choose best entry in No_Pred list
3257 No_Pred_Search : loop
3258 if Debug_Flag_N then
3259 Write_Str (" considering choice of ");
3260 Write_Unit_Name (Units.Table (U).Uname);
3263 if Units.Table (U).Elaborate_Body then
3265 (" Elaborate_Body = True, Num_Pred for body = ");
3267 (UNR.Table (Corresponding_Body (U)).Num_Pred);
3270 (" Elaborate_Body = False");
3276 -- This is a candididate to be considered for choice
3278 if Better_Choice (U, Best_So_Far) then
3279 if Debug_Flag_N then
3280 Write_Line (" tentatively chosen (best so far)");
3286 U := UNR.Table (U).Nextnp;
3287 exit No_Pred_Search when U = No_Unit_Id;
3288 end loop No_Pred_Search;
3290 -- Choose the best candidate found
3292 Choose (Elab_Order, Best_So_Far, " [Elab_Old Best_So_Far]");
3294 end Find_Elab_Order;