1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2005 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Binderr
; use Binderr
;
28 with Butil
; use Butil
;
29 with Debug
; use Debug
;
30 with Fname
; use Fname
;
32 with Namet
; use Namet
;
34 with Output
; use Output
;
35 with Targparm
; use Targparm
;
39 -- The following data structures are used to represent the graph that is
40 -- used to determine the elaboration order (using a topological sort).
42 -- The following structures are used to record successors. If A is a
43 -- successor of B in this table, it means that A must be elaborated
44 -- before B is elaborated.
46 type Successor_Id
is new Nat
;
47 -- Identification of single successor entry
49 No_Successor
: constant Successor_Id
:= 0;
50 -- Used to indicate end of list of successors
52 type Elab_All_Id
is new Nat
;
53 -- Identification of Elab_All entry link
55 No_Elab_All_Link
: constant Elab_All_Id
:= 0;
56 -- Used to indicate end of list
58 -- Succ_Reason indicates the reason for a particular elaboration link
62 -- After directly with's Before, so the spec of Before must be
63 -- elaborated before After is elaborated.
66 -- After directly mentions Before in a pragma Elaborate, so the
67 -- body of Before must be elaborate before After is elaborated.
70 -- After either mentions Before directly in a pragma Elaborate_All,
71 -- or mentions a third unit, X, which itself requires that Before be
72 -- elaborated before unit X is elaborated. The Elab_All_Link list
73 -- traces the dependencies in the latter case.
76 -- This is just like Elab_All, except that the elaborate all was not
77 -- explicitly present in the source, but rather was created by the
78 -- front end, which decided that it was "desirable".
81 -- After is a body, and Before is the corresponding spec
83 -- Successor_Link contains the information for one link
85 type Successor_Link
is record
93 -- Next successor on this list
96 -- Reason for this link
99 -- Set True if this link is needed for the special Elaborate_Body
100 -- processing described below.
102 Reason_Unit
: Unit_Id
;
103 -- For Reason = Elab, or Elab_All or Elab_Desirable, records the unit
104 -- containing the pragma leading to the link.
106 Elab_All_Link
: Elab_All_Id
;
107 -- If Reason = Elab_All or Elab_Desirable, then this points to the
108 -- first elment in a list of Elab_All entries that record the with
109 -- chain leading resulting in this particular dependency.
113 -- Note on handling of Elaborate_Body. Basically, if we have a pragma
114 -- Elaborate_Body in a unit, it means that the spec and body have to
115 -- be handled as a single entity from the point of view of determining
116 -- an elaboration order. What we do is to essentially remove the body
117 -- from consideration completely, and transfer all its links (other
118 -- than the spec link) to the spec. Then when then the spec gets chosen,
119 -- we choose the body right afterwards. We mark the links that get moved
120 -- from the body to the spec by setting their Elab_Body flag True, so
121 -- that we can understand what is going on!
123 Succ_First
: constant := 1;
125 package Succ
is new Table
.Table
(
126 Table_Component_Type
=> Successor_Link
,
127 Table_Index_Type
=> Successor_Id
,
128 Table_Low_Bound
=> Succ_First
,
129 Table_Initial
=> 500,
130 Table_Increment
=> 200,
131 Table_Name
=> "Succ");
133 -- For the case of Elaborate_All, the following table is used to record
134 -- chains of with relationships that lead to the Elab_All link. These
135 -- are used solely for diagnostic purposes
137 type Elab_All_Entry
is record
138 Needed_By
: Unit_Name_Type
;
139 -- Name of unit from which referencing unit was with'ed or otherwise
140 -- needed as a result of Elaborate_All or Elaborate_Desirable.
142 Next_Elab
: Elab_All_Id
;
143 -- Link to next entry on chain (No_Elab_All_Link marks end of list)
146 package Elab_All_Entries
is new Table
.Table
(
147 Table_Component_Type
=> Elab_All_Entry
,
148 Table_Index_Type
=> Elab_All_Id
,
149 Table_Low_Bound
=> 1,
150 Table_Initial
=> 2000,
151 Table_Increment
=> 200,
152 Table_Name
=> "Elab_All_Entries");
154 -- A Unit_Node record is built for each active unit
156 type Unit_Node_Record
is record
158 Successors
: Successor_Id
;
159 -- Pointer to list of links for successor nodes
162 -- Number of predecessors for this unit. Normally non-negative, but
163 -- can go negative in the case of units chosen by the diagnose error
164 -- procedure (when cycles are being removed from the graph).
167 -- Forward pointer for list of units with no predecessors
170 -- Position in elaboration order (zero = not placed yet)
173 -- Used in computing transitive closure for elaborate all and
174 -- also in locating cycles and paths in the diagnose routines.
176 Elab_Position
: Natural;
177 -- Initialized to zero. Set non-zero when a unit is chosen and
178 -- placed in the elaboration order. The value represents the
179 -- ordinal position in the elaboration order.
183 package UNR
is new Table
.Table
(
184 Table_Component_Type
=> Unit_Node_Record
,
185 Table_Index_Type
=> Unit_Id
,
186 Table_Low_Bound
=> First_Unit_Entry
,
187 Table_Initial
=> 500,
188 Table_Increment
=> 200,
189 Table_Name
=> "UNR");
192 -- Head of list of items with no predecessors
195 -- Number of entries not yet dealt with
198 -- Current unit, set by Gather_Dependencies, and picked up in Build_Link
199 -- to set the Reason_Unit field of the created dependency link.
201 Num_Chosen
: Natural := 0;
202 -- Number of units chosen in the elaboration order so far
204 -----------------------
205 -- Local Subprograms --
206 -----------------------
208 function Better_Choice
(U1
, U2
: Unit_Id
) return Boolean;
209 -- U1 and U2 are both permitted candidates for selection as the next unit
210 -- to be elaborated. This function determines whether U1 is a better choice
211 -- than U2, i.e. should be elaborated in preference to U2, based on a set
212 -- of heuristics that establish a friendly and predictable order (see body
213 -- for details). The result is True if U1 is a better choice than U2, and
214 -- False if it is a worse choice, or there is no preference between them.
220 Ea_Id
: Elab_All_Id
:= No_Elab_All_Link
);
221 -- Establish a successor link, Before must be elaborated before After,
222 -- and the reason for the link is R. Ea_Id is the contents to be placed
223 -- in the Elab_All_Link of the entry.
225 procedure Choose
(Chosen
: Unit_Id
);
226 -- Chosen is the next entry chosen in the elaboration order. This
227 -- procedure updates all data structures appropriately.
229 function Corresponding_Body
(U
: Unit_Id
) return Unit_Id
;
230 pragma Inline
(Corresponding_Body
);
231 -- Given a unit which is a spec for which there is a separate body,
232 -- return the unit id of the body. It is an error to call this routine
233 -- with a unit that is not a spec, or which does not have a separate body.
235 function Corresponding_Spec
(U
: Unit_Id
) return Unit_Id
;
236 pragma Inline
(Corresponding_Spec
);
237 -- Given a unit which is a body for which there is a separate spec,
238 -- return the unit id of the spec. It is an error to call this routine
239 -- with a unit that is not a body, or which does not have a separate spec.
241 procedure Diagnose_Elaboration_Problem
;
242 -- Called when no elaboration order can be found. Outputs an appropriate
243 -- diagnosis of the problem, and then abandons the bind.
245 procedure Elab_All_Links
248 Reason
: Succ_Reason
;
250 -- Used to compute the transitive closure of elaboration links for an
251 -- Elaborate_All pragma (Reason = Elab_All) or for an indication of
252 -- Elaborate_All_Desirable (Reason = Elab_Desirable). Unit After has
253 -- a pragma Elaborate_All or the front end has determined that a reference
254 -- probably requires Elaborate_All is required, and unit Before must be
255 -- previously elaborated. First a link is built making sure that unit
256 -- Before is elaborated before After, then a recursive call ensures that
257 -- we also build links for any units needed by Before (i.e. these units
258 -- must/should also be elaborated before After). Link is used to build
259 -- a chain of Elab_All_Entries to explain the reason for a link. The
260 -- value passed is the chain so far.
262 procedure Elab_Error_Msg
(S
: Successor_Id
);
263 -- Given a successor link, outputs an error message of the form
264 -- "& must be elaborated before & ..." where ... is the reason.
266 procedure Gather_Dependencies
;
267 -- Compute dependencies, building the Succ and UNR tables
269 function Make_Elab_Entry
270 (Unam
: Unit_Name_Type
;
273 -- Make an Elab_All_Entries table entry with the given Unam and Link
275 function Unit_Id_Of
(Uname
: Unit_Name_Type
) return Unit_Id
;
276 -- This function uses the Info field set in the names table to obtain
277 -- the unit Id of a unit, given its name id value.
279 function Worse_Choice
(U1
, U2
: Unit_Id
) return Boolean;
280 -- This is like Better_Choice, and has the same interface, but returns
281 -- true if U1 is a worse choice than U2 in the sense of the -h (horrible
282 -- elaboration order) switch. We still have to obey Ada rules, so it is
283 -- not quite the direct inverse of Better_Choice.
285 procedure Write_Dependencies
;
286 -- Write out dependencies (called only if appropriate option is set)
288 procedure Write_Elab_All_Chain
(S
: Successor_Id
);
289 -- If the reason for the link S is Elaborate_All or Elaborate_Desirable,
290 -- then this routine will output the "needed by" explanation chain.
296 function Better_Choice
(U1
, U2
: Unit_Id
) return Boolean is
298 function Body_Unit
(U
: Unit_Id
) return Boolean;
299 -- Determines if given unit is a body
301 function Waiting_Body
(U
: Unit_Id
) return Boolean;
302 -- Determines if U is a waiting body, defined as a body which has
303 -- not been elaborated, but whose spec has been elaborated.
305 function Body_Unit
(U
: Unit_Id
) return Boolean is
307 return Units
.Table
(U
).Utype
= Is_Body
308 or else Units
.Table
(U
).Utype
= Is_Body_Only
;
311 function Waiting_Body
(U
: Unit_Id
) return Boolean is
313 return Units
.Table
(U
).Utype
= Is_Body
314 and then UNR
.Table
(Corresponding_Spec
(U
)).Elab_Position
/= 0;
317 -- Start of processing for Better_Choice
319 -- Note: the checks here are applied in sequence, and the ordering is
320 -- significant (i.e. the more important criteria are applied first).
323 -- Prefer a waiting body to any other case
325 if Waiting_Body
(U1
) and not Waiting_Body
(U2
) then
328 elsif Waiting_Body
(U2
) and not Waiting_Body
(U1
) then
331 -- Prefer a predefined unit to a non-predefined unit
333 elsif Units
.Table
(U1
).Predefined
334 and not Units
.Table
(U2
).Predefined
338 elsif Units
.Table
(U2
).Predefined
339 and not Units
.Table
(U1
).Predefined
343 -- Prefer an internal unit to a non-internal unit
345 elsif Units
.Table
(U1
).Internal
346 and not Units
.Table
(U2
).Internal
350 elsif Units
.Table
(U2
).Internal
351 and not Units
.Table
(U1
).Internal
355 -- Prefer a body to a spec
357 elsif Body_Unit
(U1
) and not Body_Unit
(U2
) then
360 elsif Body_Unit
(U2
) and not Body_Unit
(U1
) then
363 -- If both are waiting bodies, then prefer the one whose spec is
364 -- more recently elaborated. Consider the following:
370 -- The normal waiting body preference would have placed the body of
371 -- A before the spec of B if it could. Since it could not, there it
372 -- must be the case that A depends on B. It is therefore a good idea
373 -- to put the body of B first.
375 elsif Waiting_Body
(U1
) and then Waiting_Body
(U2
) then
377 UNR
.Table
(Corresponding_Spec
(U1
)).Elab_Position
>
378 UNR
.Table
(Corresponding_Spec
(U2
)).Elab_Position
;
380 -- Otherwise decide on the basis of alphabetical order
383 return Uname_Less
(Units
.Table
(U1
).Uname
, Units
.Table
(U2
).Uname
);
395 Ea_Id
: Elab_All_Id
:= No_Elab_All_Link
)
401 Succ
.Table
(Succ
.Last
).Before
:= Before
;
402 Succ
.Table
(Succ
.Last
).Next
:= UNR
.Table
(Before
).Successors
;
403 UNR
.Table
(Before
).Successors
:= Succ
.Last
;
404 Succ
.Table
(Succ
.Last
).Reason
:= R
;
405 Succ
.Table
(Succ
.Last
).Reason_Unit
:= Cur_Unit
;
406 Succ
.Table
(Succ
.Last
).Elab_All_Link
:= Ea_Id
;
408 -- Deal with special Elab_Body case. If the After of this link is
409 -- a body whose spec has Elaborate_All set, and this is not the link
410 -- directly from the body to the spec, then we make the After of the
411 -- link reference its spec instead, marking the link appropriately.
413 if Units
.Table
(After
).Utype
= Is_Body
then
414 Cspec
:= Corresponding_Spec
(After
);
416 if Units
.Table
(Cspec
).Elaborate_Body
417 and then Cspec
/= Before
419 Succ
.Table
(Succ
.Last
).After
:= Cspec
;
420 Succ
.Table
(Succ
.Last
).Elab_Body
:= True;
421 UNR
.Table
(Cspec
).Num_Pred
:= UNR
.Table
(Cspec
).Num_Pred
+ 1;
426 -- Fall through on normal case
428 Succ
.Table
(Succ
.Last
).After
:= After
;
429 Succ
.Table
(Succ
.Last
).Elab_Body
:= False;
430 UNR
.Table
(After
).Num_Pred
:= UNR
.Table
(After
).Num_Pred
+ 1;
437 procedure Choose
(Chosen
: Unit_Id
) is
443 Write_Str
("Choosing Unit ");
444 Write_Unit_Name
(Units
.Table
(Chosen
).Uname
);
448 -- Add to elaboration order. Note that units having no elaboration
449 -- code are not treated specially yet. The special casing of this
450 -- is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile
451 -- we need them here, because the object file list is also driven
452 -- by the contents of the Elab_Order table.
454 Elab_Order
.Increment_Last
;
455 Elab_Order
.Table
(Elab_Order
.Last
) := Chosen
;
457 -- Remove from No_Pred list. This is a little inefficient and may
458 -- be we should doubly link the list, but it will do for now!
460 if No_Pred
= Chosen
then
461 No_Pred
:= UNR
.Table
(Chosen
).Nextnp
;
464 -- Note that we just ignore the situation where it does not
465 -- appear in the No_Pred list, this happens in calls from the
466 -- Diagnose_Elaboration_Problem routine, where cycles are being
467 -- removed arbitrarily from the graph.
470 while U
/= No_Unit_Id
loop
471 if UNR
.Table
(U
).Nextnp
= Chosen
then
472 UNR
.Table
(U
).Nextnp
:= UNR
.Table
(Chosen
).Nextnp
;
476 U
:= UNR
.Table
(U
).Nextnp
;
480 -- For all successors, decrement the number of predecessors, and
481 -- if it becomes zero, then add to no predecessor list.
483 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.
741 end Diagnose_Elaboration_Problem
;
747 procedure Elab_All_Links
750 Reason
: Succ_Reason
;
754 if UNR
.Table
(Before
).Visited
then
758 -- Build the direct link for Before
760 UNR
.Table
(Before
).Visited
:= True;
761 Build_Link
(Before
, After
, Reason
, Link
);
763 -- Process all units with'ed by Before recursively
766 Units
.Table
(Before
).First_With
.. Units
.Table
(Before
).Last_With
768 -- Skip if this with is an interface to a stand-alone library.
769 -- Skip also if no ALI file for this with, happens with certain
770 -- specialized generic files that do not get compiled.
772 if not Withs
.Table
(W
).SAL_Interface
773 and then Withs
.Table
(W
).Afile
/= No_File
774 and then Generic_Separately_Compiled
(Withs
.Table
(W
).Sfile
)
777 (Unit_Id_Of
(Withs
.Table
(W
).Uname
),
780 Make_Elab_Entry
(Withs
.Table
(W
).Uname
, Link
));
784 -- Process corresponding body, if there is one
786 if Units
.Table
(Before
).Utype
= Is_Spec
then
788 (Corresponding_Body
(Before
),
791 (Units
.Table
(Corresponding_Body
(Before
)).Uname
, Link
));
799 procedure Elab_Error_Msg
(S
: Successor_Id
) is
800 SL
: Successor_Link
renames Succ
.Table
(S
);
803 -- Nothing to do if internal unit involved and no -de flag
807 (Is_Internal_File_Name
(Units
.Table
(SL
.Before
).Sfile
)
809 Is_Internal_File_Name
(Units
.Table
(SL
.After
).Sfile
))
814 -- Here we want to generate output
816 Error_Msg_Name_1
:= Units
.Table
(SL
.Before
).Uname
;
819 Error_Msg_Name_2
:= Units
.Table
(Corresponding_Body
(SL
.After
)).Uname
;
821 Error_Msg_Name_2
:= Units
.Table
(SL
.After
).Uname
;
824 Error_Msg_Output
(" & must be elaborated before &", Info
=> True);
826 Error_Msg_Name_1
:= Units
.Table
(SL
.Reason_Unit
).Uname
;
831 (" reason: with clause",
836 (" reason: pragma Elaborate in unit &",
841 (" reason: pragma Elaborate_All in unit &",
844 when Elab_Desirable
=>
846 (" reason: implicit Elaborate_All in unit &",
850 (" recompile & with -gnatwl for full details",
855 (" reason: spec always elaborated before body",
859 Write_Elab_All_Chain
(S
);
862 Error_Msg_Name_1
:= Units
.Table
(SL
.Before
).Uname
;
863 Error_Msg_Name_2
:= Units
.Table
(SL
.After
).Uname
;
865 (" & must therefore be elaborated before &",
868 Error_Msg_Name_1
:= Units
.Table
(SL
.After
).Uname
;
870 (" (because & has a pragma Elaborate_Body)",
877 ---------------------
878 -- Find_Elab_Order --
879 ---------------------
881 procedure Find_Elab_Order
is
883 Best_So_Far
: Unit_Id
;
887 Num_Left
:= Int
(Units
.Last
- Units
.First
+ 1);
889 -- Initialize unit table for elaboration control
891 for U
in Units
.First
.. Units
.Last
loop
893 UNR
.Table
(UNR
.Last
).Successors
:= No_Successor
;
894 UNR
.Table
(UNR
.Last
).Num_Pred
:= 0;
895 UNR
.Table
(UNR
.Last
).Nextnp
:= No_Unit_Id
;
896 UNR
.Table
(UNR
.Last
).Elab_Order
:= 0;
897 UNR
.Table
(UNR
.Last
).Elab_Position
:= 0;
900 -- Output warning if -p used with no -gnatE units
902 if Pessimistic_Elab_Order
903 and not Dynamic_Elaboration_Checks_Specified
905 if OpenVMS_On_Target
then
906 Error_Msg
("?use of /PESSIMISTIC_ELABORATION questionable");
908 Error_Msg
("?use of -p switch questionable");
911 Error_Msg
("?since all units compiled with static elaboration model");
914 -- Gather dependencies and output them if option set
918 -- Output elaboration dependencies if option is set
920 if Elab_Dependency_Output
or Debug_Flag_E
then
924 -- Initialize the no predecessor list
926 No_Pred
:= No_Unit_Id
;
928 for U
in UNR
.First
.. UNR
.Last
loop
929 if UNR
.Table
(U
).Num_Pred
= 0 then
930 UNR
.Table
(U
).Nextnp
:= No_Pred
;
935 -- OK, now we determine the elaboration order proper. All we do is to
936 -- select the best choice from the no predecessor list until all the
937 -- nodes have been chosen.
941 -- If there are no nodes with predecessors, then either we are
942 -- done, as indicated by Num_Left being set to zero, or we have
943 -- a circularity. In the latter case, diagnose the circularity,
944 -- removing it from the graph and continue
946 Get_No_Pred
: while No_Pred
= No_Unit_Id
loop
947 exit Outer
when Num_Left
< 1;
948 Diagnose_Elaboration_Problem
;
949 end loop Get_No_Pred
;
952 Best_So_Far
:= No_Unit_Id
;
954 -- Loop to choose best entry in No_Pred list
956 No_Pred_Search
: loop
958 Write_Str
(" considering choice of ");
959 Write_Unit_Name
(Units
.Table
(U
).Uname
);
962 if Units
.Table
(U
).Elaborate_Body
then
964 (" Elaborate_Body = True, Num_Pred for body = ");
966 (Int
(UNR
.Table
(Corresponding_Body
(U
)).Num_Pred
));
969 (" Elaborate_Body = False");
975 -- This is a candididate to be considered for choice
977 if Best_So_Far
= No_Unit_Id
978 or else ((not Pessimistic_Elab_Order
)
979 and then Better_Choice
(U
, Best_So_Far
))
980 or else (Pessimistic_Elab_Order
981 and then Worse_Choice
(U
, Best_So_Far
))
984 Write_Str
(" tentatively chosen (best so far)");
991 U
:= UNR
.Table
(U
).Nextnp
;
992 exit No_Pred_Search
when U
= No_Unit_Id
;
993 end loop No_Pred_Search
;
995 -- If no candididate chosen, it means that no unit has No_Pred = 0,
996 -- but there are units left, hence we have a circular dependency,
997 -- which we will get Diagnose_Elaboration_Problem to diagnose it.
999 if Best_So_Far
= No_Unit_Id
then
1000 Diagnose_Elaboration_Problem
;
1002 -- Otherwise choose the best candidate found
1005 Choose
(Best_So_Far
);
1009 end Find_Elab_Order
;
1011 -------------------------
1012 -- Gather_Dependencies --
1013 -------------------------
1015 procedure Gather_Dependencies
is
1016 Withed_Unit
: Unit_Id
;
1019 -- Loop through all units
1021 for U
in Units
.First
.. Units
.Last
loop
1024 -- If this is not an interface to a stand-alone library and
1025 -- there is a body and a spec, then spec must be elaborated first
1026 -- Note that the corresponding spec immediately follows the body
1028 if not Units
.Table
(U
).SAL_Interface
1029 and then Units
.Table
(U
).Utype
= Is_Body
1031 Build_Link
(Corresponding_Spec
(U
), U
, Spec_First
);
1034 -- If this unit is not an interface to a stand-alone library,
1035 -- process WITH references for this unit ignoring generic units and
1036 -- interfaces to stand-alone libraries.
1038 if not Units
.Table
(U
).SAL_Interface
then
1040 W
in Units
.Table
(U
).First_With
.. Units
.Table
(U
).Last_With
1042 if Withs
.Table
(W
).Sfile
/= No_File
1043 and then (not Withs
.Table
(W
).SAL_Interface
)
1045 -- Check for special case of withing a unit that does not
1046 -- exist any more. If the unit was completely missing we
1047 -- would already have detected this, but a nasty case arises
1048 -- when we have a subprogram body with no spec, and some
1049 -- obsolete unit with's a previous (now disappeared) spec.
1051 if Get_Name_Table_Info
(Withs
.Table
(W
).Uname
) = 0 then
1052 Error_Msg_Name_1
:= Units
.Table
(U
).Sfile
;
1053 Error_Msg_Name_2
:= Withs
.Table
(W
).Uname
;
1054 Error_Msg
("% depends on & which no longer exists");
1059 Unit_Id
(Unit_Id_Of
(Withs
.Table
(W
).Uname
));
1061 -- Pragma Elaborate_All case, for this we use the recursive
1062 -- Elab_All_Links procedure to establish the links.
1064 if Withs
.Table
(W
).Elaborate_All
then
1066 -- Reset flags used to stop multiple visits to a given
1069 for Uref
in UNR
.First
.. UNR
.Last
loop
1070 UNR
.Table
(Uref
).Visited
:= False;
1073 -- Now establish all the links we need
1076 (Withed_Unit
, U
, Elab_All
,
1078 (Withs
.Table
(W
).Uname
, No_Elab_All_Link
));
1080 -- Elaborate_All_Desirable case, for this we establish
1081 -- the same links as above, but with a different reason.
1083 elsif Withs
.Table
(W
).Elab_All_Desirable
then
1085 -- Reset flags used to stop multiple visits to a given
1088 for Uref
in UNR
.First
.. UNR
.Last
loop
1089 UNR
.Table
(Uref
).Visited
:= False;
1092 -- Now establish all the links we need
1095 (Withed_Unit
, U
, Elab_Desirable
,
1097 (Withs
.Table
(W
).Uname
, No_Elab_All_Link
));
1099 -- Pragma Elaborate case. We must build a link for the
1100 -- withed unit itself, and also the corresponding body
1103 -- However, skip this processing if there is no ALI file
1104 -- for the WITH entry, because this means it is a
1105 -- generic (even when we fix the generics so that an ALI
1106 -- file is present, we probably still will have no ALI
1107 -- file for unchecked and other special cases).
1109 elsif Withs
.Table
(W
).Elaborate
1110 and then Withs
.Table
(W
).Afile
/= No_File
1112 Build_Link
(Withed_Unit
, U
, Withed
);
1114 if Units
.Table
(Withed_Unit
).Utype
= Is_Spec
then
1116 (Corresponding_Body
(Withed_Unit
), U
, Elab
);
1119 -- Case of normal WITH with no elaboration pragmas, just
1120 -- build the single link to the directly referenced unit
1123 Build_Link
(Withed_Unit
, U
, Withed
);
1132 end Gather_Dependencies
;
1134 ---------------------
1135 -- Make_Elab_Entry --
1136 ---------------------
1138 function Make_Elab_Entry
1139 (Unam
: Unit_Name_Type
;
1144 Elab_All_Entries
.Increment_Last
;
1145 Elab_All_Entries
.Table
(Elab_All_Entries
.Last
).Needed_By
:= Unam
;
1146 Elab_All_Entries
.Table
(Elab_All_Entries
.Last
).Next_Elab
:= Link
;
1147 return Elab_All_Entries
.Last
;
1148 end Make_Elab_Entry
;
1154 function Unit_Id_Of
(Uname
: Unit_Name_Type
) return Unit_Id
is
1155 Info
: constant Int
:= Get_Name_Table_Info
(Uname
);
1158 pragma Assert
(Info
/= 0 and then Unit_Id
(Info
) /= No_Unit_Id
);
1159 return Unit_Id
(Info
);
1166 function Worse_Choice
(U1
, U2
: Unit_Id
) return Boolean is
1168 function Body_Unit
(U
: Unit_Id
) return Boolean;
1169 -- Determines if given unit is a body
1171 function Waiting_Body
(U
: Unit_Id
) return Boolean;
1172 -- Determines if U is a waiting body, defined as a body which has
1173 -- not been elaborated, but whose spec has been elaborated.
1175 function Body_Unit
(U
: Unit_Id
) return Boolean is
1177 return Units
.Table
(U
).Utype
= Is_Body
1178 or else Units
.Table
(U
).Utype
= Is_Body_Only
;
1181 function Waiting_Body
(U
: Unit_Id
) return Boolean is
1183 return Units
.Table
(U
).Utype
= Is_Body
and then
1184 UNR
.Table
(Corresponding_Spec
(U
)).Elab_Position
/= 0;
1187 -- Start of processing for Worse_Choice
1189 -- Note: the checks here are applied in sequence, and the ordering is
1190 -- significant (i.e. the more important criteria are applied first).
1193 -- If either unit is internal, then use Better_Choice, since the
1194 -- language requires that predefined units not mess up in the choice
1195 -- of elaboration order, and for internal units, any problems are
1196 -- ours and not the programmers.
1198 if Units
.Table
(U1
).Internal
or else Units
.Table
(U2
).Internal
then
1199 return Better_Choice
(U1
, U2
);
1201 -- Prefer anything else to a waiting body (!)
1203 elsif Waiting_Body
(U1
) and not Waiting_Body
(U2
) then
1206 elsif Waiting_Body
(U2
) and not Waiting_Body
(U1
) then
1209 -- Prefer a spec to a body (!)
1211 elsif Body_Unit
(U1
) and not Body_Unit
(U2
) then
1214 elsif Body_Unit
(U2
) and not Body_Unit
(U1
) then
1217 -- If both are waiting bodies, then prefer the one whose spec is
1218 -- less recently elaborated. Consider the following:
1224 -- The normal waiting body preference would have placed the body of
1225 -- A before the spec of B if it could. Since it could not, there it
1226 -- must be the case that A depends on B. It is therefore a good idea
1227 -- to put the body of B last so that if there is an elaboration order
1228 -- problem, we will find it (that's what horrible order is about)
1230 elsif Waiting_Body
(U1
) and then Waiting_Body
(U2
) then
1232 UNR
.Table
(Corresponding_Spec
(U1
)).Elab_Position
<
1233 UNR
.Table
(Corresponding_Spec
(U2
)).Elab_Position
;
1235 -- Otherwise decide on the basis of alphabetical order. We do not try
1236 -- to reverse the usual choice here, since it can cause cancelling
1237 -- errors with the other inversions.
1240 return Uname_Less
(Units
.Table
(U1
).Uname
, Units
.Table
(U2
).Uname
);
1244 ------------------------
1245 -- Write_Dependencies --
1246 ------------------------
1248 procedure Write_Dependencies
is
1252 (" ELABORATION ORDER DEPENDENCIES");
1256 Info_Prefix_Suppress
:= True;
1258 for S
in Succ_First
.. Succ
.Last
loop
1262 Info_Prefix_Suppress
:= False;
1264 end Write_Dependencies
;
1266 --------------------------
1267 -- Write_Elab_All_Chain --
1268 --------------------------
1270 procedure Write_Elab_All_Chain
(S
: Successor_Id
) is
1271 ST
: constant Successor_Link
:= Succ
.Table
(S
);
1272 After
: constant Unit_Name_Type
:= Units
.Table
(ST
.After
).Uname
;
1275 Nam
: Unit_Name_Type
;
1277 First_Name
: Boolean := True;
1280 if ST
.Reason
in Elab_All
.. Elab_Desirable
then
1281 L
:= ST
.Elab_All_Link
;
1282 while L
/= No_Elab_All_Link
loop
1283 Nam
:= Elab_All_Entries
.Table
(L
).Needed_By
;
1284 Error_Msg_Name_1
:= Nam
;
1285 Error_Msg_Output
(" &", Info
=> True);
1287 Get_Name_String
(Nam
);
1289 if Name_Buffer
(Name_Len
) = 'b' then
1292 (" must be elaborated along with its spec:",
1297 (" which must be elaborated " &
1298 "along with its spec:",
1310 (" which is withed by:",
1315 First_Name
:= False;
1317 L
:= Elab_All_Entries
.Table
(L
).Next_Elab
;
1320 Error_Msg_Name_1
:= After
;
1321 Error_Msg_Output
(" &", Info
=> True);
1323 end Write_Elab_All_Chain
;