]>
Commit | Line | Data |
---|---|---|
70482933 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- B I N D E -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
fbf5a39b | 9 | -- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- |
70482933 RK |
10 | -- -- |
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, 59 Temple Place - Suite 330, Boston, -- | |
20 | -- MA 02111-1307, USA. -- | |
21 | -- -- | |
22 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 23 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
24 | -- -- |
25 | ------------------------------------------------------------------------------ | |
26 | ||
27 | with Binderr; use Binderr; | |
28 | with Butil; use Butil; | |
29 | with Debug; use Debug; | |
30 | with Fname; use Fname; | |
fbf5a39b | 31 | with Lib; use Lib; |
70482933 RK |
32 | with Namet; use Namet; |
33 | with Opt; use Opt; | |
34 | with Output; use Output; | |
35 | ||
36 | package body Binde is | |
37 | ||
38 | -- The following data structures are used to represent the graph that is | |
39 | -- used to determine the elaboration order (using a topological sort). | |
40 | ||
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. | |
44 | ||
45 | type Successor_Id is new Nat; | |
46 | -- Identification of single successor entry | |
47 | ||
48 | No_Successor : constant Successor_Id := 0; | |
49 | -- Used to indicate end of list of successors | |
50 | ||
51 | type Elab_All_Id is new Nat; | |
52 | -- Identification of Elab_All entry link | |
53 | ||
54 | No_Elab_All_Link : constant Elab_All_Id := 0; | |
55 | -- Used to indicate end of list | |
56 | ||
57 | -- Succ_Reason indicates the reason for a particular elaboration link | |
58 | ||
59 | type Succ_Reason is | |
60 | (Withed, | |
61 | -- After directly with's Before, so the spec of Before must be | |
62 | -- elaborated before After is elaborated. | |
63 | ||
64 | Elab, | |
65 | -- After directly mentions Before in a pragma Elaborate, so the | |
66 | -- body of Before must be elaborate before After is elaborated. | |
67 | ||
68 | Elab_All, | |
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. | |
73 | ||
74 | Elab_Desirable, | |
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". | |
78 | ||
79 | Spec_First); | |
80 | -- After is a body, and Before is the corresponding spec | |
81 | ||
82 | -- Successor_Link contains the information for one link | |
83 | ||
84 | type Successor_Link is record | |
85 | Before : Unit_Id; | |
86 | -- Predecessor unit | |
87 | ||
88 | After : Unit_Id; | |
89 | -- Successor unit | |
90 | ||
91 | Next : Successor_Id; | |
92 | -- Next successor on this list | |
93 | ||
94 | Reason : Succ_Reason; | |
95 | -- Reason for this link | |
96 | ||
97 | Elab_Body : Boolean; | |
98 | -- Set True if this link is needed for the special Elaborate_Body | |
99 | -- processing described below. | |
100 | ||
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. | |
104 | ||
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. | |
109 | ||
110 | end record; | |
111 | ||
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! | |
121 | ||
122 | Succ_First : constant := 1; | |
123 | ||
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"); | |
131 | ||
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 | |
135 | ||
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. | |
140 | ||
141 | Next_Elab : Elab_All_Id; | |
142 | -- Link to next entry on chain (No_Elab_All_Link marks end of list) | |
143 | end record; | |
144 | ||
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"); | |
152 | ||
153 | -- A Unit_Node record is built for each active unit | |
154 | ||
155 | type Unit_Node_Record is record | |
156 | ||
157 | Successors : Successor_Id; | |
158 | -- Pointer to list of links for successor nodes | |
159 | ||
160 | Num_Pred : Int; | |
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). | |
164 | ||
165 | Nextnp : Unit_Id; | |
166 | -- Forward pointer for list of units with no predecessors | |
167 | ||
168 | Elab_Order : Nat; | |
169 | -- Position in elaboration order (zero = not placed yet) | |
170 | ||
171 | Visited : Boolean; | |
172 | -- Used in computing transitive closure for elaborate all and | |
173 | -- also in locating cycles and paths in the diagnose routines. | |
174 | ||
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. | |
179 | ||
180 | end record; | |
181 | ||
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"); | |
189 | ||
190 | No_Pred : Unit_Id; | |
191 | -- Head of list of items with no predecessors | |
192 | ||
193 | Num_Left : Int; | |
194 | -- Number of entries not yet dealt with | |
195 | ||
196 | Cur_Unit : Unit_Id; | |
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. | |
199 | ||
200 | Num_Chosen : Natural := 0; | |
201 | -- Number of units chosen in the elaboration order so far | |
202 | ||
203 | ----------------------- | |
204 | -- Local Subprograms -- | |
205 | ----------------------- | |
206 | ||
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. | |
214 | ||
215 | procedure Build_Link | |
216 | (Before : Unit_Id; | |
217 | After : Unit_Id; | |
218 | R : Succ_Reason; | |
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. | |
223 | ||
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. | |
227 | ||
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. | |
233 | ||
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. | |
239 | ||
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. | |
243 | ||
244 | procedure Elab_All_Links | |
245 | (Before : Unit_Id; | |
246 | After : Unit_Id; | |
247 | Reason : Succ_Reason; | |
248 | Link : Elab_All_Id); | |
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. | |
260 | ||
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. | |
264 | ||
265 | procedure Gather_Dependencies; | |
266 | -- Compute dependencies, building the Succ and UNR tables | |
267 | ||
268 | function Make_Elab_Entry | |
269 | (Unam : Unit_Name_Type; | |
270 | Link : Elab_All_Id) | |
271 | return Elab_All_Id; | |
272 | -- Make an Elab_All_Entries table entry with the given Unam and Link. | |
273 | ||
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. | |
277 | ||
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. | |
283 | ||
284 | procedure Write_Dependencies; | |
285 | -- Write out dependencies (called only if appropriate option is set) | |
286 | ||
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. | |
290 | ||
291 | ------------------- | |
292 | -- Better_Choice -- | |
293 | ------------------- | |
294 | ||
295 | function Better_Choice (U1, U2 : Unit_Id) return Boolean is | |
296 | ||
297 | function Body_Unit (U : Unit_Id) return Boolean; | |
298 | -- Determines if given unit is a body | |
299 | ||
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. | |
303 | ||
304 | function Body_Unit (U : Unit_Id) return Boolean is | |
305 | begin | |
306 | return Units.Table (U).Utype = Is_Body | |
307 | or else Units.Table (U).Utype = Is_Body_Only; | |
308 | end Body_Unit; | |
309 | ||
310 | function Waiting_Body (U : Unit_Id) return Boolean is | |
311 | begin | |
312 | return Units.Table (U).Utype = Is_Body | |
313 | and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0; | |
314 | end Waiting_Body; | |
315 | ||
316 | -- Start of processing for Better_Choice | |
317 | ||
318 | -- Note: the checks here are applied in sequence, and the ordering is | |
319 | -- significant (i.e. the more important criteria are applied first). | |
320 | ||
321 | begin | |
322 | -- Prefer a waiting body to any other case | |
323 | ||
324 | if Waiting_Body (U1) and not Waiting_Body (U2) then | |
325 | return True; | |
326 | ||
327 | elsif Waiting_Body (U2) and not Waiting_Body (U1) then | |
328 | return False; | |
329 | ||
330 | -- Prefer a predefined unit to a non-predefined unit | |
331 | ||
332 | elsif Units.Table (U1).Predefined | |
333 | and not Units.Table (U2).Predefined | |
334 | then | |
335 | return True; | |
336 | ||
337 | elsif Units.Table (U2).Predefined | |
338 | and not Units.Table (U1).Predefined | |
339 | then | |
340 | return False; | |
341 | ||
342 | -- Prefer an internal unit to a non-internal unit | |
343 | ||
344 | elsif Units.Table (U1).Internal | |
345 | and not Units.Table (U2).Internal | |
346 | then | |
347 | return True; | |
348 | ||
349 | elsif Units.Table (U2).Internal | |
350 | and not Units.Table (U1).Internal | |
351 | then | |
352 | return False; | |
353 | ||
354 | -- Prefer a body to a spec | |
355 | ||
356 | elsif Body_Unit (U1) and not Body_Unit (U2) then | |
357 | return True; | |
358 | ||
359 | elsif Body_Unit (U2) and not Body_Unit (U1) then | |
360 | return False; | |
361 | ||
362 | -- If both are waiting bodies, then prefer the one whose spec is | |
363 | -- more recently elaborated. Consider the following: | |
364 | ||
365 | -- spec of A | |
366 | -- spec of B | |
367 | -- body of A or B? | |
368 | ||
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. | |
373 | ||
374 | elsif Waiting_Body (U1) and then Waiting_Body (U2) then | |
375 | return | |
376 | UNR.Table (Corresponding_Spec (U1)).Elab_Position > | |
377 | UNR.Table (Corresponding_Spec (U2)).Elab_Position; | |
378 | ||
379 | -- Otherwise decide on the basis of alphabetical order | |
380 | ||
381 | else | |
382 | return Uname_Less (Units.Table (U1).Uname, Units.Table (U2).Uname); | |
383 | end if; | |
384 | end Better_Choice; | |
385 | ||
386 | ---------------- | |
387 | -- Build_Link -- | |
388 | ---------------- | |
389 | ||
390 | procedure Build_Link | |
391 | (Before : Unit_Id; | |
392 | After : Unit_Id; | |
393 | R : Succ_Reason; | |
394 | Ea_Id : Elab_All_Id := No_Elab_All_Link) | |
395 | is | |
396 | Cspec : Unit_Id; | |
397 | ||
398 | begin | |
399 | Succ.Increment_Last; | |
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; | |
406 | ||
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. | |
411 | ||
412 | if Units.Table (After).Utype = Is_Body then | |
413 | Cspec := Corresponding_Spec (After); | |
414 | ||
415 | if Units.Table (Cspec).Elaborate_Body | |
416 | and then Cspec /= Before | |
417 | then | |
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; | |
421 | return; | |
422 | end if; | |
423 | end if; | |
424 | ||
425 | -- Fall through on normal case | |
426 | ||
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; | |
430 | end Build_Link; | |
431 | ||
432 | ------------ | |
433 | -- Choose -- | |
434 | ------------ | |
435 | ||
436 | procedure Choose (Chosen : Unit_Id) is | |
437 | S : Successor_Id; | |
438 | U : Unit_Id; | |
439 | ||
440 | begin | |
441 | if Debug_Flag_C then | |
442 | Write_Str ("Choosing Unit "); | |
443 | Write_Unit_Name (Units.Table (Chosen).Uname); | |
444 | Write_Eol; | |
445 | end if; | |
446 | ||
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. | |
452 | ||
453 | Elab_Order.Increment_Last; | |
454 | Elab_Order.Table (Elab_Order.Last) := Chosen; | |
455 | ||
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! | |
458 | ||
459 | if No_Pred = Chosen then | |
460 | No_Pred := UNR.Table (Chosen).Nextnp; | |
461 | ||
462 | else | |
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. | |
467 | ||
468 | U := No_Pred; | |
469 | while U /= No_Unit_Id loop | |
470 | if UNR.Table (U).Nextnp = Chosen then | |
471 | UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp; | |
472 | exit; | |
473 | end if; | |
474 | ||
475 | U := UNR.Table (U).Nextnp; | |
476 | end loop; | |
477 | end if; | |
478 | ||
479 | -- For all successors, decrement the number of predecessors, and | |
480 | -- if it becomes zero, then add to no predecessor list. | |
481 | ||
482 | S := UNR.Table (Chosen).Successors; | |
483 | ||
484 | while S /= No_Successor loop | |
485 | U := Succ.Table (S).After; | |
486 | UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1; | |
487 | ||
488 | if Debug_Flag_N then | |
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)); | |
493 | Write_Eol; | |
494 | end if; | |
495 | ||
496 | if UNR.Table (U).Num_Pred = 0 then | |
497 | UNR.Table (U).Nextnp := No_Pred; | |
498 | No_Pred := U; | |
499 | end if; | |
500 | ||
501 | S := Succ.Table (S).Next; | |
502 | end loop; | |
503 | ||
504 | -- All done, adjust number of units left count and set elaboration pos | |
505 | ||
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; | |
510 | ||
511 | -- If we just chose a spec with Elaborate_Body set, then we | |
512 | -- must immediately elaborate the body, before any other units. | |
513 | ||
514 | if Units.Table (Chosen).Elaborate_Body then | |
515 | ||
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. | |
519 | ||
520 | if Units.Table (Chosen).Utype = Is_Spec_Only | |
521 | and then Units.Table (Chosen).RCI | |
522 | then | |
523 | null; | |
524 | else | |
525 | Choose (Corresponding_Body (Chosen)); | |
526 | end if; | |
527 | end if; | |
528 | end Choose; | |
529 | ||
530 | ------------------------ | |
531 | -- Corresponding_Body -- | |
532 | ------------------------ | |
533 | ||
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. | |
537 | ||
538 | function Corresponding_Body (U : Unit_Id) return Unit_Id is | |
539 | begin | |
540 | pragma Assert (Units.Table (U).Utype = Is_Spec); | |
541 | return U - 1; | |
542 | end Corresponding_Body; | |
543 | ||
544 | ------------------------ | |
545 | -- Corresponding_Spec -- | |
546 | ------------------------ | |
547 | ||
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. | |
551 | ||
552 | function Corresponding_Spec (U : Unit_Id) return Unit_Id is | |
553 | begin | |
554 | pragma Assert (Units.Table (U).Utype = Is_Body); | |
555 | return U + 1; | |
556 | end Corresponding_Spec; | |
557 | ||
558 | ---------------------------------- | |
559 | -- Diagnose_Elaboration_Problem -- | |
560 | ---------------------------------- | |
561 | ||
562 | procedure Diagnose_Elaboration_Problem is | |
563 | ||
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. | |
573 | ||
574 | --------------- | |
575 | -- Find_Path -- | |
576 | --------------- | |
577 | ||
578 | function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is | |
579 | ||
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 | |
584 | ||
585 | --------------- | |
586 | -- Find_Link -- | |
587 | --------------- | |
588 | ||
589 | function Find_Link (U : Unit_Id; PL : Nat) return Boolean is | |
590 | S : Successor_Id; | |
591 | ||
592 | begin | |
593 | -- Recursion ends if we are at terminating node and the path | |
594 | -- is sufficiently long, generate error message and return True. | |
595 | ||
596 | if U = Uto and then PL >= ML then | |
597 | Choose (U); | |
598 | return True; | |
599 | ||
600 | -- All done if already visited, otherwise mark as visited | |
601 | ||
602 | elsif UNR.Table (U).Visited then | |
603 | return False; | |
604 | ||
605 | -- Otherwise mark as visited and look at all successors | |
606 | ||
607 | else | |
608 | UNR.Table (U).Visited := True; | |
609 | ||
610 | S := UNR.Table (U).Successors; | |
611 | while S /= No_Successor loop | |
612 | if Find_Link (Succ.Table (S).After, PL + 1) then | |
613 | Elab_Error_Msg (S); | |
614 | Choose (U); | |
615 | return True; | |
616 | end if; | |
617 | ||
618 | S := Succ.Table (S).Next; | |
619 | end loop; | |
620 | ||
621 | -- Falling through means this does not lead to a path | |
622 | ||
623 | return False; | |
624 | end if; | |
625 | end Find_Link; | |
626 | ||
627 | -- Start of processing for Find_Path | |
628 | ||
629 | begin | |
630 | -- Initialize all non-chosen nodes to not visisted yet | |
631 | ||
632 | for U in Units.First .. Units.Last loop | |
633 | UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0; | |
634 | end loop; | |
635 | ||
636 | -- Now try to find the path | |
637 | ||
638 | return Find_Link (Ufrom, 0); | |
639 | end Find_Path; | |
640 | ||
641 | -- Start of processing for Diagnose_Elaboration_Error | |
642 | ||
643 | begin | |
644 | Set_Standard_Error; | |
645 | ||
646 | -- Output state of things if debug flag N set | |
647 | ||
648 | if Debug_Flag_N then | |
649 | declare | |
650 | NP : Int; | |
651 | ||
652 | begin | |
653 | Write_Eol; | |
654 | Write_Eol; | |
655 | Write_Str ("Diagnose_Elaboration_Problem called"); | |
656 | Write_Eol; | |
657 | Write_Str ("List of remaining unchosen units and predecessors"); | |
658 | Write_Eol; | |
659 | ||
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; | |
663 | Write_Eol; | |
664 | Write_Str (" Unchosen unit: #"); | |
665 | Write_Int (Int (U)); | |
666 | Write_Str (" "); | |
667 | Write_Unit_Name (Units.Table (U).Uname); | |
668 | Write_Str (" (Num_Pred = "); | |
669 | Write_Int (NP); | |
670 | Write_Char (')'); | |
671 | Write_Eol; | |
672 | ||
673 | if NP = 0 then | |
674 | if Units.Table (U).Elaborate_Body then | |
675 | Write_Str | |
676 | (" (not chosen because of Elaborate_Body)"); | |
677 | Write_Eol; | |
678 | else | |
679 | Write_Str (" ****************** why not chosen?"); | |
680 | Write_Eol; | |
681 | end if; | |
682 | end if; | |
683 | ||
684 | -- Search links list to find unchosen predecessors | |
685 | ||
686 | for S in Succ.First .. Succ.Last loop | |
687 | declare | |
688 | SL : Successor_Link renames Succ.Table (S); | |
689 | ||
690 | begin | |
691 | if SL.After = U | |
692 | and then UNR.Table (SL.Before).Elab_Position = 0 | |
693 | then | |
694 | Write_Str (" unchosen predecessor: #"); | |
695 | Write_Int (Int (SL.Before)); | |
696 | Write_Str (" "); | |
697 | Write_Unit_Name (Units.Table (SL.Before).Uname); | |
698 | Write_Eol; | |
699 | NP := NP - 1; | |
700 | end if; | |
701 | end; | |
702 | end loop; | |
703 | ||
704 | if NP /= 0 then | |
705 | Write_Str (" **************** Num_Pred value wrong!"); | |
706 | Write_Eol; | |
707 | end if; | |
708 | end if; | |
709 | end loop; | |
710 | end; | |
711 | end if; | |
712 | ||
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: | |
716 | ||
717 | -- This is really only one error, not one for each line | |
718 | -- We want this output on standard output since it is voluminous | |
719 | ||
720 | -- But we do need to deal with the error count manually in this case | |
721 | ||
722 | Errors_Detected := Errors_Detected + 1; | |
723 | Error_Msg_Output ("elaboration circularity detected", Info => False); | |
724 | ||
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!) | |
728 | ||
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; | |
733 | end if; | |
734 | end if; | |
735 | end loop; | |
736 | ||
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. | |
739 | ||
740 | raise Program_Error; | |
741 | ||
742 | end Diagnose_Elaboration_Problem; | |
743 | ||
744 | -------------------- | |
745 | -- Elab_All_Links -- | |
746 | -------------------- | |
747 | ||
748 | procedure Elab_All_Links | |
749 | (Before : Unit_Id; | |
750 | After : Unit_Id; | |
751 | Reason : Succ_Reason; | |
752 | Link : Elab_All_Id) | |
753 | is | |
754 | begin | |
755 | if UNR.Table (Before).Visited then | |
756 | return; | |
757 | end if; | |
758 | ||
759 | -- Build the direct link for Before | |
760 | ||
761 | UNR.Table (Before).Visited := True; | |
762 | Build_Link (Before, After, Reason, Link); | |
763 | ||
764 | -- Process all units with'ed by Before recursively | |
765 | ||
766 | for W in | |
767 | Units.Table (Before).First_With .. Units.Table (Before).Last_With | |
768 | loop | |
fbf5a39b AC |
769 | -- Skip if this with is an interface to a stand-alone library. |
770 | -- Skip also if no ALI file for this with, happens with certain | |
70482933 RK |
771 | -- specialized generic files that do not get compiled. |
772 | ||
fbf5a39b AC |
773 | if not Withs.Table (W).Interface |
774 | and then Withs.Table (W).Afile /= No_File | |
775 | and then Generic_Separately_Compiled (Withs.Table (W).Sfile) | |
776 | then | |
70482933 RK |
777 | Elab_All_Links |
778 | (Unit_Id_Of (Withs.Table (W).Uname), | |
779 | After, | |
780 | Reason, | |
781 | Make_Elab_Entry (Withs.Table (W).Uname, Link)); | |
782 | end if; | |
783 | end loop; | |
784 | ||
785 | -- Process corresponding body, if there is one | |
786 | ||
787 | if Units.Table (Before).Utype = Is_Spec then | |
788 | Elab_All_Links | |
789 | (Corresponding_Body (Before), | |
790 | After, Reason, | |
791 | Make_Elab_Entry | |
792 | (Units.Table (Corresponding_Body (Before)).Uname, Link)); | |
793 | end if; | |
794 | end Elab_All_Links; | |
795 | ||
796 | -------------------- | |
797 | -- Elab_Error_Msg -- | |
798 | -------------------- | |
799 | ||
800 | procedure Elab_Error_Msg (S : Successor_Id) is | |
801 | SL : Successor_Link renames Succ.Table (S); | |
802 | ||
803 | begin | |
804 | -- Nothing to do if internal unit involved and no -de flag | |
805 | ||
806 | if not Debug_Flag_E | |
807 | and then | |
808 | (Is_Internal_File_Name (Units.Table (SL.Before).Sfile) | |
809 | or else | |
810 | Is_Internal_File_Name (Units.Table (SL.After).Sfile)) | |
811 | then | |
812 | return; | |
813 | end if; | |
814 | ||
815 | -- Here we want to generate output | |
816 | ||
817 | Error_Msg_Name_1 := Units.Table (SL.Before).Uname; | |
818 | ||
819 | if SL.Elab_Body then | |
820 | Error_Msg_Name_2 := Units.Table (Corresponding_Body (SL.After)).Uname; | |
821 | else | |
822 | Error_Msg_Name_2 := Units.Table (SL.After).Uname; | |
823 | end if; | |
824 | ||
825 | Error_Msg_Output (" & must be elaborated before &", Info => True); | |
826 | ||
827 | Error_Msg_Name_1 := Units.Table (SL.Reason_Unit).Uname; | |
828 | ||
829 | case SL.Reason is | |
830 | when Withed => | |
831 | Error_Msg_Output | |
832 | (" reason: with clause", | |
833 | Info => True); | |
834 | ||
835 | when Elab => | |
836 | Error_Msg_Output | |
837 | (" reason: pragma Elaborate in unit &", | |
838 | Info => True); | |
839 | ||
840 | when Elab_All => | |
841 | Error_Msg_Output | |
842 | (" reason: pragma Elaborate_All in unit &", | |
843 | Info => True); | |
844 | ||
845 | when Elab_Desirable => | |
846 | Error_Msg_Output | |
fbf5a39b | 847 | (" reason: implicit Elaborate_All in unit &", |
70482933 RK |
848 | Info => True); |
849 | ||
850 | Error_Msg_Output | |
851 | (" recompile & with -gnatwl for full details", | |
852 | Info => True); | |
853 | ||
854 | when Spec_First => | |
855 | Error_Msg_Output | |
856 | (" reason: spec always elaborated before body", | |
857 | Info => True); | |
858 | end case; | |
859 | ||
860 | Write_Elab_All_Chain (S); | |
861 | ||
862 | if SL.Elab_Body then | |
863 | Error_Msg_Name_1 := Units.Table (SL.Before).Uname; | |
864 | Error_Msg_Name_2 := Units.Table (SL.After).Uname; | |
865 | Error_Msg_Output | |
866 | (" & must therefore be elaborated before &", | |
867 | True); | |
868 | ||
869 | Error_Msg_Name_1 := Units.Table (SL.After).Uname; | |
870 | Error_Msg_Output | |
871 | (" (because & has a pragma Elaborate_Body)", | |
872 | True); | |
873 | end if; | |
874 | ||
875 | Write_Eol; | |
876 | end Elab_Error_Msg; | |
877 | ||
878 | --------------------- | |
879 | -- Find_Elab_Order -- | |
880 | --------------------- | |
881 | ||
882 | procedure Find_Elab_Order is | |
883 | U : Unit_Id; | |
884 | Best_So_Far : Unit_Id; | |
885 | ||
886 | begin | |
887 | Succ.Init; | |
888 | Num_Left := Int (Units.Last - Units.First + 1); | |
889 | ||
890 | -- Initialize unit table for elaboration control | |
891 | ||
892 | for U in Units.First .. Units.Last loop | |
893 | UNR.Increment_Last; | |
894 | UNR.Table (UNR.Last).Successors := No_Successor; | |
895 | UNR.Table (UNR.Last).Num_Pred := 0; | |
896 | UNR.Table (UNR.Last).Nextnp := No_Unit_Id; | |
897 | UNR.Table (UNR.Last).Elab_Order := 0; | |
898 | UNR.Table (UNR.Last).Elab_Position := 0; | |
899 | end loop; | |
900 | ||
901 | -- Gather dependencies and output them if option set | |
902 | ||
903 | Gather_Dependencies; | |
904 | ||
905 | -- Output elaboration dependencies if option is set | |
906 | ||
907 | if Elab_Dependency_Output or Debug_Flag_E then | |
908 | Write_Dependencies; | |
909 | end if; | |
910 | ||
911 | -- Initialize the no predecessor list | |
912 | ||
913 | No_Pred := No_Unit_Id; | |
914 | ||
915 | for U in UNR.First .. UNR.Last loop | |
916 | if UNR.Table (U).Num_Pred = 0 then | |
917 | UNR.Table (U).Nextnp := No_Pred; | |
918 | No_Pred := U; | |
919 | end if; | |
920 | end loop; | |
921 | ||
922 | -- OK, now we determine the elaboration order proper. All we do is to | |
923 | -- select the best choice from the no predecessor list until all the | |
924 | -- nodes have been chosen. | |
925 | ||
926 | Outer : loop | |
927 | -- If there are no nodes with predecessors, then either we are | |
928 | -- done, as indicated by Num_Left being set to zero, or we have | |
929 | -- a circularity. In the latter case, diagnose the circularity, | |
930 | -- removing it from the graph and continue | |
931 | ||
932 | Get_No_Pred : while No_Pred = No_Unit_Id loop | |
933 | exit Outer when Num_Left < 1; | |
934 | Diagnose_Elaboration_Problem; | |
935 | end loop Get_No_Pred; | |
936 | ||
937 | U := No_Pred; | |
938 | Best_So_Far := No_Unit_Id; | |
939 | ||
940 | -- Loop to choose best entry in No_Pred list | |
941 | ||
942 | No_Pred_Search : loop | |
943 | if Debug_Flag_N then | |
944 | Write_Str (" considering choice of "); | |
945 | Write_Unit_Name (Units.Table (U).Uname); | |
946 | Write_Eol; | |
947 | ||
948 | if Units.Table (U).Elaborate_Body then | |
949 | Write_Str | |
950 | (" Elaborate_Body = True, Num_Pred for body = "); | |
951 | Write_Int | |
952 | (Int (UNR.Table (Corresponding_Body (U)).Num_Pred)); | |
953 | else | |
954 | Write_Str | |
955 | (" Elaborate_Body = False"); | |
956 | end if; | |
957 | ||
958 | Write_Eol; | |
959 | end if; | |
960 | ||
961 | -- This is a candididate to be considered for choice | |
962 | ||
963 | if Best_So_Far = No_Unit_Id | |
964 | or else ((not Pessimistic_Elab_Order) | |
965 | and then Better_Choice (U, Best_So_Far)) | |
966 | or else (Pessimistic_Elab_Order | |
967 | and then Worse_Choice (U, Best_So_Far)) | |
968 | then | |
969 | if Debug_Flag_N then | |
970 | Write_Str (" tentatively chosen (best so far)"); | |
971 | Write_Eol; | |
972 | end if; | |
973 | ||
974 | Best_So_Far := U; | |
975 | end if; | |
976 | ||
977 | U := UNR.Table (U).Nextnp; | |
978 | exit No_Pred_Search when U = No_Unit_Id; | |
979 | end loop No_Pred_Search; | |
980 | ||
981 | -- If no candididate chosen, it means that no unit has No_Pred = 0, | |
982 | -- but there are units left, hence we have a circular dependency, | |
983 | -- which we will get Diagnose_Elaboration_Problem to diagnose it. | |
984 | ||
985 | if Best_So_Far = No_Unit_Id then | |
986 | Diagnose_Elaboration_Problem; | |
987 | ||
988 | -- Otherwise choose the best candidate found | |
989 | ||
990 | else | |
991 | Choose (Best_So_Far); | |
992 | end if; | |
993 | end loop Outer; | |
994 | ||
995 | end Find_Elab_Order; | |
996 | ||
997 | ------------------------- | |
998 | -- Gather_Dependencies -- | |
999 | ------------------------- | |
1000 | ||
1001 | procedure Gather_Dependencies is | |
1002 | Withed_Unit : Unit_Id; | |
1003 | ||
1004 | begin | |
1005 | -- Loop through all units | |
1006 | ||
1007 | for U in Units.First .. Units.Last loop | |
1008 | Cur_Unit := U; | |
1009 | ||
fbf5a39b AC |
1010 | -- If this is not an interface to a stand-alone library and |
1011 | -- there is a body and a spec, then spec must be elaborated first | |
70482933 RK |
1012 | -- Note that the corresponding spec immediately follows the body |
1013 | ||
fbf5a39b AC |
1014 | if not Units.Table (U).Interface |
1015 | and then Units.Table (U).Utype = Is_Body | |
1016 | then | |
70482933 RK |
1017 | Build_Link (Corresponding_Spec (U), U, Spec_First); |
1018 | end if; | |
1019 | ||
fbf5a39b AC |
1020 | -- If this unit is not an interface to a stand-alone library, |
1021 | -- process WITH references for this unit ignoring generic units and | |
1022 | -- interfaces to stand-alone libraries. | |
70482933 | 1023 | |
fbf5a39b AC |
1024 | if not Units.Table (U).Interface then |
1025 | for | |
1026 | W in Units.Table (U).First_With .. Units.Table (U).Last_With | |
1027 | loop | |
1028 | if Withs.Table (W).Sfile /= No_File | |
1029 | and then (not Withs.Table (W).Interface) | |
1030 | then | |
1031 | -- Check for special case of withing a unit that does not | |
1032 | -- exist any more. If the unit was completely missing we | |
1033 | -- would already have detected this, but a nasty case arises | |
1034 | -- when we have a subprogram body with no spec, and some | |
1035 | -- obsolete unit with's a previous (now disappeared) spec. | |
1036 | ||
1037 | if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then | |
1038 | Error_Msg_Name_1 := Units.Table (U).Sfile; | |
1039 | Error_Msg_Name_2 := Withs.Table (W).Uname; | |
1040 | Error_Msg ("% depends on & which no longer exists"); | |
1041 | goto Next_With; | |
1042 | end if; | |
70482933 | 1043 | |
fbf5a39b AC |
1044 | Withed_Unit := |
1045 | Unit_Id (Unit_Id_Of (Withs.Table (W).Uname)); | |
70482933 | 1046 | |
fbf5a39b AC |
1047 | -- Pragma Elaborate_All case, for this we use the recursive |
1048 | -- Elab_All_Links procedure to establish the links. | |
70482933 | 1049 | |
fbf5a39b | 1050 | if Withs.Table (W).Elaborate_All then |
70482933 | 1051 | |
fbf5a39b AC |
1052 | -- Reset flags used to stop multiple visits to a given |
1053 | -- node. | |
70482933 | 1054 | |
fbf5a39b AC |
1055 | for Uref in UNR.First .. UNR.Last loop |
1056 | UNR.Table (Uref).Visited := False; | |
1057 | end loop; | |
70482933 | 1058 | |
fbf5a39b | 1059 | -- Now establish all the links we need |
70482933 | 1060 | |
fbf5a39b AC |
1061 | Elab_All_Links |
1062 | (Withed_Unit, U, Elab_All, | |
1063 | Make_Elab_Entry | |
1064 | (Withs.Table (W).Uname, No_Elab_All_Link)); | |
70482933 | 1065 | |
fbf5a39b AC |
1066 | -- Elaborate_All_Desirable case, for this we establish |
1067 | -- the same links as above, but with a different reason. | |
70482933 | 1068 | |
fbf5a39b | 1069 | elsif Withs.Table (W).Elab_All_Desirable then |
70482933 | 1070 | |
fbf5a39b AC |
1071 | -- Reset flags used to stop multiple visits to a given |
1072 | -- node. | |
70482933 | 1073 | |
fbf5a39b AC |
1074 | for Uref in UNR.First .. UNR.Last loop |
1075 | UNR.Table (Uref).Visited := False; | |
1076 | end loop; | |
70482933 | 1077 | |
fbf5a39b | 1078 | -- Now establish all the links we need |
70482933 | 1079 | |
fbf5a39b AC |
1080 | Elab_All_Links |
1081 | (Withed_Unit, U, Elab_Desirable, | |
1082 | Make_Elab_Entry | |
1083 | (Withs.Table (W).Uname, No_Elab_All_Link)); | |
70482933 | 1084 | |
fbf5a39b AC |
1085 | -- Pragma Elaborate case. We must build a link for the |
1086 | -- withed unit itself, and also the corresponding body | |
1087 | -- if there is one. | |
70482933 | 1088 | |
fbf5a39b AC |
1089 | -- However, skip this processing if there is no ALI file |
1090 | -- for the WITH entry, because this means it is a | |
1091 | -- generic (even when we fix the generics so that an ALI | |
1092 | -- file is present, we probably still will have no ALI | |
1093 | -- file for unchecked and other special cases). | |
70482933 | 1094 | |
fbf5a39b AC |
1095 | elsif Withs.Table (W).Elaborate |
1096 | and then Withs.Table (W).Afile /= No_File | |
1097 | then | |
1098 | Build_Link (Withed_Unit, U, Withed); | |
70482933 | 1099 | |
fbf5a39b AC |
1100 | if Units.Table (Withed_Unit).Utype = Is_Spec then |
1101 | Build_Link | |
1102 | (Corresponding_Body (Withed_Unit), U, Elab); | |
1103 | end if; | |
70482933 | 1104 | |
fbf5a39b AC |
1105 | -- Case of normal WITH with no elaboration pragmas, just |
1106 | -- build the single link to the directly referenced unit | |
70482933 | 1107 | |
fbf5a39b AC |
1108 | else |
1109 | Build_Link (Withed_Unit, U, Withed); | |
70482933 | 1110 | end if; |
70482933 | 1111 | end if; |
70482933 | 1112 | |
fbf5a39b | 1113 | <<Next_With>> |
70482933 | 1114 | null; |
fbf5a39b AC |
1115 | end loop; |
1116 | end if; | |
70482933 RK |
1117 | end loop; |
1118 | end Gather_Dependencies; | |
1119 | ||
1120 | --------------------- | |
1121 | -- Make_Elab_Entry -- | |
1122 | --------------------- | |
1123 | ||
1124 | function Make_Elab_Entry | |
1125 | (Unam : Unit_Name_Type; | |
1126 | Link : Elab_All_Id) | |
1127 | return Elab_All_Id | |
1128 | is | |
1129 | begin | |
1130 | Elab_All_Entries.Increment_Last; | |
1131 | Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam; | |
1132 | Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link; | |
1133 | return Elab_All_Entries.Last; | |
1134 | end Make_Elab_Entry; | |
1135 | ||
1136 | ---------------- | |
1137 | -- Unit_Id_Of -- | |
1138 | ---------------- | |
1139 | ||
1140 | function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is | |
1141 | Info : constant Int := Get_Name_Table_Info (Uname); | |
1142 | ||
1143 | begin | |
1144 | pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); | |
1145 | return Unit_Id (Info); | |
1146 | end Unit_Id_Of; | |
1147 | ||
1148 | ------------------ | |
1149 | -- Worse_Choice -- | |
1150 | ------------------ | |
1151 | ||
1152 | function Worse_Choice (U1, U2 : Unit_Id) return Boolean is | |
1153 | ||
1154 | function Body_Unit (U : Unit_Id) return Boolean; | |
1155 | -- Determines if given unit is a body | |
1156 | ||
1157 | function Waiting_Body (U : Unit_Id) return Boolean; | |
1158 | -- Determines if U is a waiting body, defined as a body which has | |
1159 | -- not been elaborated, but whose spec has been elaborated. | |
1160 | ||
1161 | function Body_Unit (U : Unit_Id) return Boolean is | |
1162 | begin | |
1163 | return Units.Table (U).Utype = Is_Body | |
1164 | or else Units.Table (U).Utype = Is_Body_Only; | |
1165 | end Body_Unit; | |
1166 | ||
1167 | function Waiting_Body (U : Unit_Id) return Boolean is | |
1168 | begin | |
1169 | return Units.Table (U).Utype = Is_Body and then | |
1170 | UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0; | |
1171 | end Waiting_Body; | |
1172 | ||
1173 | -- Start of processing for Worse_Choice | |
1174 | ||
1175 | -- Note: the checks here are applied in sequence, and the ordering is | |
1176 | -- significant (i.e. the more important criteria are applied first). | |
1177 | ||
1178 | begin | |
1179 | -- If either unit is internal, then use Better_Choice, since the | |
1180 | -- language requires that predefined units not mess up in the choice | |
1181 | -- of elaboration order, and for internal units, any problems are | |
1182 | -- ours and not the programmers. | |
1183 | ||
1184 | if Units.Table (U1).Internal or else Units.Table (U2).Internal then | |
1185 | return Better_Choice (U1, U2); | |
1186 | ||
1187 | -- Prefer anything else to a waiting body (!) | |
1188 | ||
1189 | elsif Waiting_Body (U1) and not Waiting_Body (U2) then | |
1190 | return False; | |
1191 | ||
1192 | elsif Waiting_Body (U2) and not Waiting_Body (U1) then | |
1193 | return True; | |
1194 | ||
1195 | -- Prefer a spec to a body (!) | |
1196 | ||
1197 | elsif Body_Unit (U1) and not Body_Unit (U2) then | |
1198 | return False; | |
1199 | ||
1200 | elsif Body_Unit (U2) and not Body_Unit (U1) then | |
1201 | return True; | |
1202 | ||
1203 | -- If both are waiting bodies, then prefer the one whose spec is | |
1204 | -- less recently elaborated. Consider the following: | |
1205 | ||
1206 | -- spec of A | |
1207 | -- spec of B | |
1208 | -- body of A or B? | |
1209 | ||
1210 | -- The normal waiting body preference would have placed the body of | |
1211 | -- A before the spec of B if it could. Since it could not, there it | |
1212 | -- must be the case that A depends on B. It is therefore a good idea | |
1213 | -- to put the body of B last so that if there is an elaboration order | |
1214 | -- problem, we will find it (that's what horrible order is about) | |
1215 | ||
1216 | elsif Waiting_Body (U1) and then Waiting_Body (U2) then | |
1217 | return | |
1218 | UNR.Table (Corresponding_Spec (U1)).Elab_Position < | |
1219 | UNR.Table (Corresponding_Spec (U2)).Elab_Position; | |
1220 | ||
1221 | -- Otherwise decide on the basis of alphabetical order. We do not try | |
1222 | -- to reverse the usual choice here, since it can cause cancelling | |
1223 | -- errors with the other inversions. | |
1224 | ||
1225 | else | |
1226 | return Uname_Less (Units.Table (U1).Uname, Units.Table (U2).Uname); | |
1227 | end if; | |
1228 | end Worse_Choice; | |
1229 | ||
1230 | ------------------------ | |
1231 | -- Write_Dependencies -- | |
1232 | ------------------------ | |
1233 | ||
1234 | procedure Write_Dependencies is | |
1235 | begin | |
1236 | Write_Eol; | |
1237 | Write_Str | |
1238 | (" ELABORATION ORDER DEPENDENCIES"); | |
1239 | Write_Eol; | |
1240 | Write_Eol; | |
1241 | ||
1242 | Info_Prefix_Suppress := True; | |
1243 | ||
1244 | for S in Succ_First .. Succ.Last loop | |
1245 | Elab_Error_Msg (S); | |
1246 | end loop; | |
1247 | ||
1248 | Info_Prefix_Suppress := False; | |
1249 | Write_Eol; | |
1250 | end Write_Dependencies; | |
1251 | ||
1252 | -------------------------- | |
1253 | -- Write_Elab_All_Chain -- | |
1254 | -------------------------- | |
1255 | ||
1256 | procedure Write_Elab_All_Chain (S : Successor_Id) is | |
1257 | ST : constant Successor_Link := Succ.Table (S); | |
1258 | After : constant Unit_Name_Type := Units.Table (ST.After).Uname; | |
1259 | ||
1260 | L : Elab_All_Id; | |
1261 | Nam : Unit_Name_Type; | |
1262 | ||
1263 | First_Name : Boolean := True; | |
1264 | ||
1265 | begin | |
1266 | if ST.Reason in Elab_All .. Elab_Desirable then | |
1267 | L := ST.Elab_All_Link; | |
1268 | while L /= No_Elab_All_Link loop | |
1269 | Nam := Elab_All_Entries.Table (L).Needed_By; | |
1270 | Error_Msg_Name_1 := Nam; | |
1271 | Error_Msg_Output (" &", Info => True); | |
1272 | ||
1273 | Get_Name_String (Nam); | |
1274 | ||
1275 | if Name_Buffer (Name_Len) = 'b' then | |
1276 | if First_Name then | |
1277 | Error_Msg_Output | |
1278 | (" must be elaborated along with its spec:", | |
1279 | Info => True); | |
1280 | ||
1281 | else | |
1282 | Error_Msg_Output | |
1283 | (" which must be elaborated " & | |
1284 | "along with its spec:", | |
1285 | Info => True); | |
1286 | end if; | |
1287 | ||
1288 | else | |
1289 | if First_Name then | |
1290 | Error_Msg_Output | |
1291 | (" is withed by:", | |
1292 | Info => True); | |
1293 | ||
1294 | else | |
1295 | Error_Msg_Output | |
1296 | (" which is withed by:", | |
1297 | Info => True); | |
1298 | end if; | |
1299 | end if; | |
1300 | ||
1301 | First_Name := False; | |
1302 | ||
1303 | L := Elab_All_Entries.Table (L).Next_Elab; | |
1304 | end loop; | |
1305 | ||
1306 | Error_Msg_Name_1 := After; | |
1307 | Error_Msg_Output (" &", Info => True); | |
1308 | end if; | |
1309 | end Write_Elab_All_Chain; | |
1310 | ||
1311 | end Binde; |