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