1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                                B I N D E                                 --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2020, Free Software Foundation, Inc.         --
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 3,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17-- for  more details.  You should have  received  a copy of the GNU General --
18-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19-- http://www.gnu.org/licenses for a complete copy of the license.          --
20--                                                                          --
21-- GNAT was originally developed  by the GNAT team at  New York University. --
22-- Extensive contributions were provided by Ada Core Technologies Inc.      --
23--                                                                          --
24------------------------------------------------------------------------------
25
26with Binderr; use Binderr;
27with Butil;   use Butil;
28with Debug;   use Debug;
29with Fname;   use Fname;
30with Opt;     use Opt;
31with Osint;
32with Output;  use Output;
33with Table;
34with Types;   use Types;
35
36with System.Case_Util; use System.Case_Util;
37with System.HTable;
38
39package body Binde is
40   use Unit_Id_Tables;
41
42   --  We now have Elab_New, a new elaboration-order algorithm.
43   --
44   --  However, any change to elaboration order can break some programs.
45   --  Therefore, we are keeping the old algorithm in place, to be selected
46   --  by switches.
47   --
48   --  The new algorithm has the following interesting properties:
49   --
50   --    * The static and dynamic models use the same elaboration order. The
51   --      static model might get an error, but if it does not, it will use
52   --      the same order as the dynamic model.
53   --
54   --    * Each SCC (see below) is elaborated together; that is, units from
55   --      different SCCs are not interspersed.
56   --
57   --    * In particular, this implies that if an SCC contains just a spec and
58   --      the corresponding body, and nothing else, the body will be
59   --      elaborated immediately after the spec. This is expected to result
60   --      in a better elaboration order for most programs, because in this
61   --      case, a call from outside the library unit cannot get ABE.
62   --
63   --    * Pragmas Elaborate_All (explicit and implicit) are ignored. Instead,
64   --      we behave as if every legal pragma Elaborate_All were present. That
65   --      is, if it would be legal to have "pragma Elaborate_All(Y);" on X,
66   --      then we behave as if such a pragma exists, even if it does not.
67
68   Do_Old : constant Boolean := False;
69   Do_New : constant Boolean := True;
70   --  True to enable the old and new algorithms, respectively. Used for
71   --  debugging/experimentation.
72
73   Doing_New : Boolean := False;
74   --  True if we are currently doing the new algorithm. Print certain
75   --  messages only when doing the "new" elab order algorithm, so we don't get
76   --  duplicates. And use different heuristics in Better_Choice_Optimistic.
77
78   --  The following data structures are used to represent the graph that is
79   --  used to determine the elaboration order (using a topological sort).
80
81   --  The following structures are used to record successors. If B is a
82   --  successor of A in this table, it means that A must be elaborated before
83   --  B is elaborated. For example, if Y (body) says "with X;", then Y (body)
84   --  will be a successor of X (spec), and X (spec) will be a predecessor of
85   --  Y (body).
86   --
87   --  Note that we store the successors of each unit explicitly. We don't
88   --  store the predecessors, but we store a count of them.
89   --
90   --  The basic algorithm is to first compute a directed graph of units (type
91   --  Unit_Node_Record, below), with successors as edges. A unit is "ready"
92   --  (to be chosen as the next to be elaborated) if it has no predecessors
93   --  that have not yet been chosen. We use heuristics to decide which of the
94   --  ready units should be elaborated next, and "choose" that one (which
95   --  means we append it to the elaboration-order table).
96
97   type Successor_Id is new Nat;
98   --  Identification of single successor entry
99
100   No_Successor : constant Successor_Id := 0;
101   --  Used to indicate end of list of successors
102
103   type Elab_All_Id is new Nat;
104   --  Identification of Elab_All entry link
105
106   No_Elab_All_Link : constant Elab_All_Id := 0;
107   --  Used to indicate end of list
108
109   --  Succ_Reason indicates the reason for a particular elaboration link
110
111   type Succ_Reason is
112     (Withed,
113      --  After directly with's Before, so the spec of Before must be
114      --  elaborated before After is elaborated.
115
116      Forced,
117      --  Before and After come from a pair of lines in the forced-elaboration-
118      --  order file.
119
120      Elab,
121      --  After directly mentions Before in a pragma Elaborate, so the body of
122      --  Before must be elaborated before After is elaborated.
123
124      Elab_All,
125      --  After either mentions Before directly in a pragma Elaborate_All, or
126      --  mentions a third unit, X, which itself requires that Before be
127      --  elaborated before unit X is elaborated. The Elab_All_Link list traces
128      --  the dependencies in the latter case.
129
130      Elab_All_Desirable,
131      --  This is just like Elab_All, except that the Elaborate_All was not
132      --  explicitly present in the source, but rather was created by the front
133      --  end, which decided that it was "desirable".
134
135      Elab_Desirable,
136      --  This is just like Elab, except that the Elaborate was not explicitly
137      --  present in the source, but rather was created by the front end, which
138      --  decided that it was "desirable".
139
140      Spec_First);
141      --  After is a body, and Before is the corresponding spec
142
143   --  Successor_Link contains the information for one link
144
145   type Successor_Link is record
146      Before : Unit_Id;
147      --  Predecessor unit
148
149      After : Unit_Id;
150      --  Successor unit
151
152      Next : Successor_Id;
153      --  Next successor on this list
154
155      Reason : Succ_Reason;
156      --  Reason for this link
157
158      Elab_Body : Boolean;
159      --  Set True if this link is needed for the special Elaborate_Body
160      --  processing described below.
161
162      Reason_Unit : Unit_Id;
163      --  For Reason = Elab, or Elab_All or Elab_Desirable, records the unit
164      --  containing the pragma leading to the link.
165
166      Elab_All_Link : Elab_All_Id;
167      --  If Reason = Elab_All or Elab_Desirable, then this points to the
168      --  first element in a list of Elab_All entries that record the with
169      --  chain resulting in this particular dependency.
170   end record;
171
172   --  Note on handling of Elaborate_Body. Basically, if we have a pragma
173   --  Elaborate_Body in a unit, it means that the spec and body have to be
174   --  handled as a single entity from the point of view of determining an
175   --  elaboration order. What we do is to essentially remove the body from
176   --  consideration completely, and transfer all its links (other than the
177   --  spec link) to the spec. Then when the spec gets chosen, we choose the
178   --  body right afterwards. We mark the links that get moved from the body to
179   --  the spec by setting their Elab_Body flag True, so that we can understand
180   --  what is going on.
181
182   Succ_First : constant := 1;
183
184   package Succ is new Table.Table
185     (Table_Component_Type => Successor_Link,
186      Table_Index_Type     => Successor_Id,
187      Table_Low_Bound      => Succ_First,
188      Table_Initial        => 500,
189      Table_Increment      => 200,
190      Table_Name           => "Succ");
191
192   --  For the case of Elaborate_All, the following table is used to record
193   --  chains of with relationships that lead to the Elab_All link. These are
194   --  used solely for diagnostic purposes
195
196   type Elab_All_Entry is record
197      Needed_By : Unit_Name_Type;
198      --  Name of unit from which referencing unit was with'ed or otherwise
199      --  needed as a result of Elaborate_All or Elaborate_Desirable.
200
201      Next_Elab : Elab_All_Id;
202      --  Link to next entry on chain (No_Elab_All_Link marks end of list)
203   end record;
204
205   package Elab_All_Entries is new Table.Table
206     (Table_Component_Type => Elab_All_Entry,
207      Table_Index_Type     => Elab_All_Id,
208      Table_Low_Bound      => 1,
209      Table_Initial        => 2000,
210      Table_Increment      => 200,
211      Table_Name           => "Elab_All_Entries");
212
213   type Unit_Id_Array_Ptr is access Unit_Id_Array;
214
215   --  A Unit_Node_Record is built for each active unit
216
217   type Unit_Node_Record is record
218      Successors : Successor_Id;
219      --  Pointer to list of links for successor nodes
220
221      Num_Pred : Int;
222      --  Number of predecessors for this unit that have not yet been chosen.
223      --  Normally non-negative, but can go negative in the case of units
224      --  chosen by the diagnose error procedure (when cycles are being removed
225      --  from the graph).
226
227      Nextnp : Unit_Id;
228      --  Forward pointer for list of units with no predecessors
229
230      Visited : Boolean;
231      --  Used in computing transitive closure for Elaborate_All and also in
232      --  locating cycles and paths in the diagnose routines.
233
234      Elab_Position : Nat;
235      --  Initialized to zero. Set non-zero when a unit is chosen and placed in
236      --  the elaboration order. The value represents the ordinal position in
237      --  the elaboration order.
238
239      --  The following are for Elab_New. We compute the strongly connected
240      --  components (SCCs) of the directed graph of units. The edges are the
241      --  Successors, which do not include pragmas Elaborate_All (explicit or
242      --  implicit) in Elab_New. In addition, we assume there is a edge
243      --  pointing from a body to its corresponding spec; this edge is not
244      --  included in Successors, because of course a spec is elaborated BEFORE
245      --  its body, not after.
246
247      SCC_Root : Unit_Id;
248      --  Each unit points to the root of its SCC, which is just an arbitrary
249      --  member of the SCC. Two units are in the same SCC if and only if their
250      --  SCC_Roots are equal. U is the root of its SCC if and only if
251      --  SCC(U)=U.
252
253      Nodes : Unit_Id_Array_Ptr;
254      --  Present only in the root of an SCC. This is the set of units in the
255      --  SCC, in no particular order.
256
257      SCC_Num_Pred : Int;
258      --  Present only in the root of an SCC. This is the number of predecessor
259      --  units of the SCC that are in other SCCs, and that have not yet been
260      --  chosen.
261
262      Validate_Seen : Boolean := False;
263      --  See procedure Validate below
264   end record;
265
266   package UNR is new Table.Table
267     (Table_Component_Type => Unit_Node_Record,
268      Table_Index_Type     => Unit_Id,
269      Table_Low_Bound      => First_Unit_Entry,
270      Table_Initial        => 500,
271      Table_Increment      => 200,
272      Table_Name           => "UNR");
273
274   No_Pred : Unit_Id;
275   --  Head of list of items with no predecessors
276
277   Num_Left : Int;
278   --  Number of entries not yet dealt with
279
280   Cur_Unit : Unit_Id;
281   --  Current unit, set by Gather_Dependencies, and picked up in Build_Link to
282   --  set the Reason_Unit field of the created dependency link.
283
284   Num_Chosen : Nat;
285   --  Number of units chosen in the elaboration order so far
286
287   Diagnose_Elaboration_Problem_Called : Boolean := False;
288   --  True if Diagnose_Elaboration_Problem was called. Used in an assertion.
289
290   -----------------------
291   -- Local Subprograms --
292   -----------------------
293
294   function Debug_Flag_Older return Boolean;
295   function Debug_Flag_Old return Boolean;
296   --  True if debug flags select the old or older algorithms. Pretty much any
297   --  change to elaboration order can break some programs. For example,
298   --  programs can depend on elaboration order even without failing
299   --  access-before-elaboration checks. A trivial example is a program that
300   --  prints text during elaboration. Therefore, we have flags to revert to
301   --  the old(er) algorithms.
302
303   procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean);
304   --  Assert that certain properties are true
305
306   function Better_Choice_Optimistic
307     (U1 : Unit_Id;
308      U2 : Unit_Id) return Boolean;
309   --  U1 and U2 are both permitted candidates for selection as the next unit
310   --  to be elaborated. This function determines whether U1 is a better choice
311   --  than U2, i.e. should be elaborated in preference to U2, based on a set
312   --  of heuristics that establish a friendly and predictable order (see body
313   --  for details). The result is True if U1 is a better choice than U2, and
314   --  False if it is a worse choice, or there is no preference between them.
315
316   function Better_Choice_Pessimistic
317     (U1 : Unit_Id;
318      U2 : Unit_Id) return Boolean;
319   --  This is like Better_Choice_Optimistic, and has the same interface, but
320   --  returns true if U1 is a worse choice than U2 in the sense of the -p
321   --  (pessimistic elaboration order) switch. We still have to obey Ada rules,
322   --  so it is not quite the direct inverse of Better_Choice_Optimistic.
323
324   function Better_Choice (U1 : Unit_Id; U2 : Unit_Id) return Boolean;
325   --  Calls Better_Choice_Optimistic or Better_Choice_Pessimistic as
326   --  appropriate. Also takes care of the U2 = No_Unit_Id case.
327
328   procedure Build_Link
329     (Before : Unit_Id;
330      After  : Unit_Id;
331      R      : Succ_Reason;
332      Ea_Id  : Elab_All_Id := No_Elab_All_Link);
333   --  Establish a successor link, Before must be elaborated before After, and
334   --  the reason for the link is R. Ea_Id is the contents to be placed in the
335   --  Elab_All_Link of the entry.
336
337   procedure Choose
338     (Elab_Order : in out Unit_Id_Table;
339      Chosen     : Unit_Id;
340      Msg        : String);
341   --  Chosen is the next entry chosen in the elaboration order. This procedure
342   --  updates all data structures appropriately.
343
344   function Corresponding_Body (U : Unit_Id) return Unit_Id;
345   pragma Inline (Corresponding_Body);
346   --  Given a unit that is a spec for which there is a separate body, return
347   --  the unit id of the body. It is an error to call this routine with a unit
348   --  that is not a spec, or that does not have a separate body.
349
350   function Corresponding_Spec (U : Unit_Id) return Unit_Id;
351   pragma Inline (Corresponding_Spec);
352   --  Given a unit that is a body for which there is a separate spec, return
353   --  the unit id of the spec. It is an error to call this routine with a unit
354   --  that is not a body, or that does not have a separate spec.
355
356   procedure Diagnose_Elaboration_Problem
357     (Elab_Order : in out Unit_Id_Table);
358   pragma No_Return (Diagnose_Elaboration_Problem);
359   --  Called when no elaboration order can be found. Outputs an appropriate
360   --  diagnosis of the problem, and then abandons the bind.
361
362   procedure Elab_All_Links
363     (Before : Unit_Id;
364      After  : Unit_Id;
365      Reason : Succ_Reason;
366      Link   : Elab_All_Id);
367   --  Used to compute the transitive closure of elaboration links for an
368   --  Elaborate_All pragma (Reason = Elab_All) or for an indication of
369   --  Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has a
370   --  pragma Elaborate_All or the front end has determined that a reference
371   --  probably requires Elaborate_All, and unit Before must be previously
372   --  elaborated. First a link is built making sure that unit Before is
373   --  elaborated before After, then a recursive call ensures that we also
374   --  build links for any units needed by Before (i.e. these units must/should
375   --  also be elaborated before After). Link is used to build a chain of
376   --  Elab_All_Entries to explain the reason for a link. The value passed is
377   --  the chain so far.
378
379   procedure Elab_Error_Msg (S : Successor_Id);
380   --  Given a successor link, outputs an error message of the form
381   --  "$ must be elaborated before $ ..." where ... is the reason.
382
383   procedure Force_Elab_Order;
384   --  Gather dependencies from the forced-elaboration-order file (-f switch)
385
386   procedure Gather_Dependencies;
387   --  Compute dependencies, building the Succ and UNR tables
388
389   procedure Init;
390   --  Initialize global data structures in this package body
391
392   function Is_Body_Unit (U : Unit_Id) return Boolean;
393   pragma Inline (Is_Body_Unit);
394   --  Determines if given unit is a body
395
396   function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean;
397   --  Returns True if corresponding unit is Pure or Preelaborate. Includes
398   --  dealing with testing flags on spec if it is given a body.
399
400   function Is_Waiting_Body (U : Unit_Id) return Boolean;
401   pragma Inline (Is_Waiting_Body);
402   --  Determines if U is a waiting body, defined as a body that has
403   --  not been elaborated, but whose spec has been elaborated.
404
405   function Make_Elab_All_Entry
406     (Unam : Unit_Name_Type;
407      Link : Elab_All_Id) return Elab_All_Id;
408   --  Make an Elab_All_Entries table entry with the given Unam and Link
409
410   function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id;
411   --  This function uses the Info field set in the names table to obtain
412   --  the unit Id of a unit, given its name id value.
413
414   procedure Write_Closure (Order : Unit_Id_Array);
415   --  Write the closure. This is for the -R and -Ra switches, "list closure
416   --  display".
417
418   procedure Write_Dependencies;
419   --  Write out dependencies (called only if appropriate option is set)
420
421   procedure Write_Elab_All_Chain (S : Successor_Id);
422   --  If the reason for the link S is Elaborate_All or Elaborate_Desirable,
423   --  then this routine will output the "needed by" explanation chain.
424
425   procedure Write_Elab_Order (Order : Unit_Id_Array; Title : String);
426   --  Display elaboration order. This is for the -l switch. Title is a heading
427   --  to print; an empty string is passed to indicate Zero_Formatting.
428
429   package Elab_New is
430
431      --  Implementation of the new algorithm
432
433      procedure Write_SCC (U : Unit_Id);
434      --  Write the unit names of the units in the SCC in which U lives
435
436      procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table);
437
438      Elab_Cycle_Found : Boolean := False;
439      --  Set True if Find_Elab_Order found a cycle (usually an illegal pragma
440      --  Elaborate_All, explicit or implicit).
441
442      function SCC (U : Unit_Id) return Unit_Id;
443      --  The root of the strongly connected component containing U
444
445      function SCC_Num_Pred (U : Unit_Id) return Int;
446      --  The SCC_Num_Pred of the SCC in which U lives
447
448      function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr;
449      --  The nodes of the strongly connected component containing U
450
451   end Elab_New;
452
453   use Elab_New;
454
455   package Elab_Old is
456
457      --  Implementation of the old algorithm
458
459      procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table);
460
461   end Elab_Old;
462
463   --  Most of the code is shared between old and new; such code is outside
464   --  packages Elab_Old and Elab_New.
465
466   -------------------
467   -- Better_Choice --
468   -------------------
469
470   function Better_Choice (U1 : Unit_Id; U2 : Unit_Id) return Boolean is
471      pragma Assert (U1 /= No_Unit_Id);
472   begin
473      if U2 = No_Unit_Id then
474         return True;
475      end if;
476
477      if Pessimistic_Elab_Order then
478         return Better_Choice_Pessimistic (U1, U2);
479      else
480         return Better_Choice_Optimistic (U1, U2);
481      end if;
482   end Better_Choice;
483
484   ------------------------------
485   -- Better_Choice_Optimistic --
486   ------------------------------
487
488   function Better_Choice_Optimistic
489     (U1 : Unit_Id;
490      U2 : Unit_Id) return Boolean
491   is
492      UT1 : Unit_Record renames Units.Table (U1);
493      UT2 : Unit_Record renames Units.Table (U2);
494
495   begin
496      if Debug_Flag_B then
497         Write_Str ("Better_Choice_Optimistic (");
498         Write_Unit_Name (UT1.Uname);
499         Write_Str (", ");
500         Write_Unit_Name (UT2.Uname);
501         Write_Line (")");
502      end if;
503
504      --  Note: the checks here are applied in sequence, and the ordering is
505      --  significant (i.e. the more important criteria are applied first).
506
507      --  Prefer a waiting body to one that is not a waiting body
508
509      if Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
510         if Debug_Flag_B then
511            Write_Line ("  True: u1 is waiting body, u2 is not");
512         end if;
513
514         return True;
515
516      elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
517         if Debug_Flag_B then
518            Write_Line ("  False: u2 is waiting body, u1 is not");
519         end if;
520
521         return False;
522
523      --  Prefer a predefined unit to a non-predefined unit
524
525      elsif UT1.Predefined and then not UT2.Predefined then
526         if Debug_Flag_B then
527            Write_Line ("  True: u1 is predefined, u2 is not");
528         end if;
529
530         return True;
531
532      elsif UT2.Predefined and then not UT1.Predefined then
533         if Debug_Flag_B then
534            Write_Line ("  False: u2 is predefined, u1 is not");
535         end if;
536
537         return False;
538
539      --  Prefer an internal unit to a non-internal unit
540
541      elsif UT1.Internal and then not UT2.Internal then
542         if Debug_Flag_B then
543            Write_Line ("  True: u1 is internal, u2 is not");
544         end if;
545         return True;
546
547      elsif UT2.Internal and then not UT1.Internal then
548         if Debug_Flag_B then
549            Write_Line ("  False: u2 is internal, u1 is not");
550         end if;
551
552         return False;
553
554      --  Prefer a pure or preelaborated unit to one that is not. Pure should
555      --  come before preelaborated.
556
557      elsif Is_Pure_Or_Preelab_Unit (U1)
558              and then not
559            Is_Pure_Or_Preelab_Unit (U2)
560      then
561         if Debug_Flag_B then
562            Write_Line ("  True: u1 is pure/preelab, u2 is not");
563         end if;
564
565         return True;
566
567      elsif Is_Pure_Or_Preelab_Unit (U2)
568              and then not
569            Is_Pure_Or_Preelab_Unit (U1)
570      then
571         if Debug_Flag_B then
572            Write_Line ("  False: u2 is pure/preelab, u1 is not");
573         end if;
574
575         return False;
576
577      --  Prefer a body to a spec
578
579      elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
580         if Debug_Flag_B then
581            Write_Line ("  True: u1 is body, u2 is not");
582         end if;
583
584         return True;
585
586      elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
587         if Debug_Flag_B then
588            Write_Line ("  False: u2 is body, u1 is not");
589         end if;
590
591         return False;
592
593      --  If both are waiting bodies, then prefer the one whose spec is more
594      --  recently elaborated. Consider the following:
595
596      --     spec of A
597      --     spec of B
598      --     body of A or B?
599
600      --  The normal waiting body preference would have placed the body of A
601      --  before the spec of B if it could. Since it could not, then it must be
602      --  the case that A depends on B. It is therefore a good idea to put the
603      --  body of B first.
604
605      elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
606         declare
607            Result : constant Boolean :=
608                       UNR.Table (Corresponding_Spec (U1)).Elab_Position >
609                       UNR.Table (Corresponding_Spec (U2)).Elab_Position;
610         begin
611            if Debug_Flag_B then
612               if Result then
613                  Write_Line ("  True: based on waiting body elab positions");
614               else
615                  Write_Line ("  False: based on waiting body elab positions");
616               end if;
617            end if;
618
619            return Result;
620         end;
621      end if;
622
623      --  Remaining choice rules are disabled by Debug flag -do
624
625      if not Debug_Flag_Older then
626
627         --  The following deal with the case of specs that have been marked
628         --  as Elaborate_Body_Desirable. We generally want to delay these
629         --  specs as long as possible, so that the bodies have a better chance
630         --  of being elaborated closer to the specs.
631
632         --  If we have two units, one of which is a spec for which this flag
633         --  is set, and the other is not, we prefer to delay the spec for
634         --  which the flag is set.
635
636         if not UT1.Elaborate_Body_Desirable
637           and then UT2.Elaborate_Body_Desirable
638         then
639            if Debug_Flag_B then
640               Write_Line ("  True: u1 is elab body desirable, u2 is not");
641            end if;
642
643            return True;
644
645         elsif not UT2.Elaborate_Body_Desirable
646           and then UT1.Elaborate_Body_Desirable
647         then
648            if Debug_Flag_B then
649               Write_Line ("  False: u1 is elab body desirable, u2 is not");
650            end if;
651
652            return False;
653
654            --  If we have two specs that are both marked as Elaborate_Body
655            --  desirable, we prefer the one whose body is nearer to being able
656            --  to be elaborated, based on the Num_Pred count. This helps to
657            --  ensure bodies are as close to specs as possible.
658
659         elsif UT1.Elaborate_Body_Desirable
660           and then UT2.Elaborate_Body_Desirable
661         then
662            declare
663               Result : constant Boolean :=
664                          UNR.Table (Corresponding_Body (U1)).Num_Pred <
665                          UNR.Table (Corresponding_Body (U2)).Num_Pred;
666            begin
667               if Debug_Flag_B then
668                  if Result then
669                     Write_Line ("  True based on Num_Pred compare");
670                  else
671                     Write_Line ("  False based on Num_Pred compare");
672                  end if;
673               end if;
674
675               return Result;
676            end;
677         end if;
678      end if;
679
680      --  If we have two specs in the same SCC, choose the one whose body is
681      --  closer to being ready.
682
683      if Doing_New
684        and then SCC (U1) = SCC (U2)
685        and then Units.Table (U1).Utype = Is_Spec
686        and then Units.Table (U2).Utype = Is_Spec
687        and then UNR.Table (Corresponding_Body (U1)).Num_Pred /=
688                 UNR.Table (Corresponding_Body (U2)).Num_Pred
689      then
690         if UNR.Table (Corresponding_Body (U1)).Num_Pred <
691           UNR.Table (Corresponding_Body (U2)).Num_Pred
692         then
693            if Debug_Flag_B then
694               Write_Str ("  True: same SCC; ");
695               Write_Int (UNR.Table (Corresponding_Body (U1)).Num_Pred);
696               Write_Str (" < ");
697               Write_Int (UNR.Table (Corresponding_Body (U2)).Num_Pred);
698               Write_Eol;
699            end if;
700
701            return True;
702         else
703            if Debug_Flag_B then
704               Write_Str ("  False: same SCC; ");
705               Write_Int (UNR.Table (Corresponding_Body (U1)).Num_Pred);
706               Write_Str (" > ");
707               Write_Int (UNR.Table (Corresponding_Body (U2)).Num_Pred);
708               Write_Eol;
709            end if;
710
711            return False;
712         end if;
713      end if;
714
715      --  If we fall through, it means that no preference rule applies, so we
716      --  use alphabetical order to at least give a deterministic result.
717
718      if Debug_Flag_B then
719         Write_Line ("  choose on alpha order");
720      end if;
721
722      return Uname_Less (UT1.Uname, UT2.Uname);
723   end Better_Choice_Optimistic;
724
725   -------------------------------
726   -- Better_Choice_Pessimistic --
727   -------------------------------
728
729   function Better_Choice_Pessimistic
730     (U1 : Unit_Id;
731      U2 : Unit_Id) return Boolean
732   is
733      UT1 : Unit_Record renames Units.Table (U1);
734      UT2 : Unit_Record renames Units.Table (U2);
735
736   begin
737      if Debug_Flag_B then
738         Write_Str ("Better_Choice_Pessimistic (");
739         Write_Unit_Name (UT1.Uname);
740         Write_Str (", ");
741         Write_Unit_Name (UT2.Uname);
742         Write_Line (")");
743      end if;
744
745      --  Note: the checks here are applied in sequence, and the ordering is
746      --  significant (i.e. the more important criteria are applied first).
747
748      --  If either unit is predefined or internal, then we use the normal
749      --  Better_Choice_Optimistic rule, since we don't want to disturb the
750      --  elaboration rules of the language with -p; same treatment for
751      --  Pure/Preelab.
752
753      --  Prefer a predefined unit to a non-predefined unit
754
755      if UT1.Predefined and then not UT2.Predefined then
756         if Debug_Flag_B then
757            Write_Line ("  True: u1 is predefined, u2 is not");
758         end if;
759
760         return True;
761
762      elsif UT2.Predefined and then not UT1.Predefined then
763         if Debug_Flag_B then
764            Write_Line ("  False: u2 is predefined, u1 is not");
765         end if;
766
767         return False;
768
769      --  Prefer an internal unit to a non-internal unit
770
771      elsif UT1.Internal and then not UT2.Internal then
772         if Debug_Flag_B then
773            Write_Line ("  True: u1 is internal, u2 is not");
774         end if;
775
776         return True;
777
778      elsif UT2.Internal and then not UT1.Internal then
779         if Debug_Flag_B then
780            Write_Line ("  False: u2 is internal, u1 is not");
781         end if;
782
783         return False;
784
785      --  Prefer a pure or preelaborated unit to one that is not
786
787      elsif Is_Pure_Or_Preelab_Unit (U1)
788              and then not
789            Is_Pure_Or_Preelab_Unit (U2)
790      then
791         if Debug_Flag_B then
792            Write_Line ("  True: u1 is pure/preelab, u2 is not");
793         end if;
794
795         return True;
796
797      elsif Is_Pure_Or_Preelab_Unit (U2)
798              and then not
799            Is_Pure_Or_Preelab_Unit (U1)
800      then
801         if Debug_Flag_B then
802            Write_Line ("  False: u2 is pure/preelab, u1 is not");
803         end if;
804
805         return False;
806
807      --  Prefer anything else to a waiting body. We want to make bodies wait
808      --  as long as possible, till we are forced to choose them.
809
810      elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
811         if Debug_Flag_B then
812            Write_Line ("  False: u1 is waiting body, u2 is not");
813         end if;
814
815         return False;
816
817      elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
818         if Debug_Flag_B then
819            Write_Line ("  True: u2 is waiting body, u1 is not");
820         end if;
821
822         return True;
823
824      --  Prefer a spec to a body (this is mandatory)
825
826      elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
827         if Debug_Flag_B then
828            Write_Line ("  False: u1 is body, u2 is not");
829         end if;
830
831         return False;
832
833      elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
834         if Debug_Flag_B then
835            Write_Line ("  True: u2 is body, u1 is not");
836         end if;
837
838         return True;
839
840      --  If both are waiting bodies, then prefer the one whose spec is less
841      --  recently elaborated. Consider the following:
842
843      --     spec of A
844      --     spec of B
845      --     body of A or B?
846
847      --  The normal waiting body preference would have placed the body of A
848      --  before the spec of B if it could. Since it could not, then it must be
849      --  the case that A depends on B. It is therefore a good idea to put the
850      --  body of B last so that if there is an elaboration order problem, we
851      --  will find it (that's what pessimistic order is about).
852
853      elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
854         declare
855            Result : constant Boolean :=
856                       UNR.Table (Corresponding_Spec (U1)).Elab_Position <
857                       UNR.Table (Corresponding_Spec (U2)).Elab_Position;
858         begin
859            if Debug_Flag_B then
860               if Result then
861                  Write_Line ("  True: based on waiting body elab positions");
862               else
863                  Write_Line ("  False: based on waiting body elab positions");
864               end if;
865            end if;
866
867            return Result;
868         end;
869      end if;
870
871      --  Remaining choice rules are disabled by Debug flag -do
872
873      if not Debug_Flag_Older then
874
875         --  The following deal with the case of specs that have been marked as
876         --  Elaborate_Body_Desirable. In the normal case, we generally want to
877         --  delay the elaboration of these specs as long as possible, so that
878         --  bodies have better chance of being elaborated closer to the specs.
879         --  Better_Choice_Pessimistic as usual wants to do the opposite and
880         --  elaborate such specs as early as possible.
881
882         --  If we have two units, one of which is a spec for which this flag
883         --  is set, and the other is not, we normally prefer to delay the spec
884         --  for which the flag is set, so again Better_Choice_Pessimistic does
885         --  the opposite.
886
887         if not UT1.Elaborate_Body_Desirable
888           and then UT2.Elaborate_Body_Desirable
889         then
890            if Debug_Flag_B then
891               Write_Line ("  False: u1 is elab body desirable, u2 is not");
892            end if;
893
894            return False;
895
896         elsif not UT2.Elaborate_Body_Desirable
897           and then UT1.Elaborate_Body_Desirable
898         then
899            if Debug_Flag_B then
900               Write_Line ("  True: u1 is elab body desirable, u2 is not");
901            end if;
902
903            return True;
904
905            --  If we have two specs that are both marked as Elaborate_Body
906            --  desirable, we normally prefer the one whose body is nearer to
907            --  being able to be elaborated, based on the Num_Pred count. This
908            --  helps to ensure bodies are as close to specs as possible. As
909            --  usual, Better_Choice_Pessimistic does the opposite.
910
911         elsif UT1.Elaborate_Body_Desirable
912           and then UT2.Elaborate_Body_Desirable
913         then
914            declare
915               Result : constant Boolean :=
916                          UNR.Table (Corresponding_Body (U1)).Num_Pred >=
917                          UNR.Table (Corresponding_Body (U2)).Num_Pred;
918            begin
919               if Debug_Flag_B then
920                  if Result then
921                     Write_Line ("  True based on Num_Pred compare");
922                  else
923                     Write_Line ("  False based on Num_Pred compare");
924                  end if;
925               end if;
926
927               return Result;
928            end;
929         end if;
930      end if;
931
932      --  If we fall through, it means that no preference rule applies, so we
933      --  use alphabetical order to at least give a deterministic result. Since
934      --  Better_Choice_Pessimistic is in the business of stirring up the
935      --  order, we will use reverse alphabetical ordering.
936
937      if Debug_Flag_B then
938         Write_Line ("  choose on reverse alpha order");
939      end if;
940
941      return Uname_Less (UT2.Uname, UT1.Uname);
942   end Better_Choice_Pessimistic;
943
944   ----------------
945   -- Build_Link --
946   ----------------
947
948   procedure Build_Link
949     (Before : Unit_Id;
950      After  : Unit_Id;
951      R      : Succ_Reason;
952      Ea_Id  : Elab_All_Id := No_Elab_All_Link)
953   is
954      Cspec : Unit_Id;
955
956   begin
957      Succ.Append
958        ((Before        => Before,
959          After         => No_Unit_Id, -- filled in below
960          Next          => UNR.Table (Before).Successors,
961          Reason        => R,
962          Elab_Body     => False, -- set correctly below
963          Reason_Unit   => Cur_Unit,
964          Elab_All_Link => Ea_Id));
965      UNR.Table (Before).Successors := Succ.Last;
966
967      --  Deal with special Elab_Body case. If the After of this link is
968      --  a body whose spec has Elaborate_All set, and this is not the link
969      --  directly from the body to the spec, then we make the After of the
970      --  link reference its spec instead, marking the link appropriately.
971
972      if Units.Table (After).Utype = Is_Body then
973         Cspec := Corresponding_Spec (After);
974
975         if Units.Table (Cspec).Elaborate_Body
976           and then Cspec /= Before
977         then
978            Succ.Table (Succ.Last).After     := Cspec;
979            Succ.Table (Succ.Last).Elab_Body := True;
980            UNR.Table (Cspec).Num_Pred       := UNR.Table (Cspec).Num_Pred + 1;
981            return;
982         end if;
983      end if;
984
985      --  Fall through on normal case
986
987      Succ.Table (Succ.Last).After     := After;
988      Succ.Table (Succ.Last).Elab_Body := False;
989      UNR.Table (After).Num_Pred       := UNR.Table (After).Num_Pred + 1;
990   end Build_Link;
991
992   ------------
993   -- Choose --
994   ------------
995
996   procedure Choose
997     (Elab_Order : in out Unit_Id_Table;
998      Chosen     : Unit_Id;
999      Msg        : String)
1000   is
1001      pragma Assert (Chosen /= No_Unit_Id);
1002      S : Successor_Id;
1003      U : Unit_Id;
1004
1005   begin
1006      if Debug_Flag_C then
1007         Write_Str ("Choosing Unit ");
1008         Write_Unit_Name (Units.Table (Chosen).Uname);
1009         Write_Str (Msg);
1010      end if;
1011
1012      --  We shouldn't be choosing something with unelaborated predecessors,
1013      --  and we shouldn't call this twice on the same unit. But that's not
1014      --  true when this is called from Diagnose_Elaboration_Problem.
1015
1016      if Errors_Detected = 0 then
1017         pragma Assert (UNR.Table (Chosen).Num_Pred = 0);
1018         pragma Assert (UNR.Table (Chosen).Elab_Position = 0);
1019         pragma Assert (not Doing_New or else SCC_Num_Pred (Chosen) = 0);
1020         null;
1021      end if;
1022
1023      --  Add to elaboration order. Note that units having no elaboration code
1024      --  are not treated specially yet. The special casing of this is in
1025      --  Bindgen, where Gen_Elab_Calls skips over them. Meanwhile we need them
1026      --  here, because the object file list is also driven by the contents of
1027      --  the Elab_Order table.
1028
1029      Append (Elab_Order, Chosen);
1030
1031      --  Remove from No_Pred list. This is a little inefficient and may be we
1032      --  should doubly link the list, but it will do for now.
1033
1034      if No_Pred = Chosen then
1035         No_Pred := UNR.Table (Chosen).Nextnp;
1036      else
1037         U := No_Pred;
1038         while U /= No_Unit_Id loop
1039            if UNR.Table (U).Nextnp = Chosen then
1040               UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp;
1041               goto Done_Removal;
1042            end if;
1043
1044            U := UNR.Table (U).Nextnp;
1045         end loop;
1046
1047         --  Here if we didn't find it on the No_Pred list. This can happen
1048         --  only in calls from the Diagnose_Elaboration_Problem routine,
1049         --  where cycles are being removed arbitrarily from the graph.
1050
1051         pragma Assert (Errors_Detected > 0);
1052         <<Done_Removal>> null;
1053      end if;
1054
1055      --  For all successors, decrement the number of predecessors, and if it
1056      --  becomes zero, then add to no-predecessor list.
1057
1058      S := UNR.Table (Chosen).Successors;
1059      pragma Annotate (CodePeer, Modified, S);
1060
1061      while S /= No_Successor loop
1062         U := Succ.Table (S).After;
1063         UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1;
1064
1065         if Debug_Flag_N then
1066            Write_Str ("  decrementing Num_Pred for unit ");
1067            Write_Unit_Name (Units.Table (U).Uname);
1068            Write_Str (" new value = ");
1069            Write_Int (UNR.Table (U).Num_Pred);
1070            Write_Eol;
1071         end if;
1072
1073         if UNR.Table (U).Num_Pred = 0 then
1074            UNR.Table (U).Nextnp := No_Pred;
1075            No_Pred := U;
1076         end if;
1077
1078         if Doing_New and then SCC (U) /= SCC (Chosen) then
1079            UNR.Table (SCC (U)).SCC_Num_Pred :=
1080              UNR.Table (SCC (U)).SCC_Num_Pred - 1;
1081
1082            if Debug_Flag_N then
1083               Write_Str ("  decrementing SCC_Num_Pred for unit ");
1084               Write_Unit_Name (Units.Table (U).Uname);
1085               Write_Str (" new value = ");
1086               Write_Int (SCC_Num_Pred (U));
1087               Write_Eol;
1088            end if;
1089         end if;
1090
1091         S := Succ.Table (S).Next;
1092      end loop;
1093
1094      --  All done, adjust number of units left count and set elaboration pos
1095
1096      Num_Left   := Num_Left   - 1;
1097      Num_Chosen := Num_Chosen + 1;
1098
1099      pragma Assert
1100        (Errors_Detected > 0 or else Num_Chosen = Last (Elab_Order));
1101      pragma Assert (Units.Last = UNR.Last);
1102      pragma Assert (Num_Chosen + Num_Left = Int (UNR.Last));
1103
1104      if Debug_Flag_C then
1105         Write_Str (" ");
1106         Write_Int (Int (Num_Chosen));
1107         Write_Str ("+");
1108         Write_Int (Num_Left);
1109         Write_Str ("=");
1110         Write_Int (Int (UNR.Last));
1111         Write_Eol;
1112      end if;
1113
1114      UNR.Table (Chosen).Elab_Position := Num_Chosen;
1115
1116      --  If we just chose a spec with Elaborate_Body set, then we must
1117      --  immediately elaborate the body, before any other units.
1118
1119      if Units.Table (Chosen).Elaborate_Body then
1120
1121         --  If the unit is a spec only, then there is no body. This is a bit
1122         --  odd given that Elaborate_Body is here, but it is valid in an RCI
1123         --  unit, where we only have the interface in the stub bind.
1124
1125         if Units.Table (Chosen).Utype = Is_Spec_Only
1126           and then Units.Table (Chosen).RCI
1127         then
1128            null;
1129
1130         --  If this unit is an interface to a stand-alone library, then we
1131         --  don't want to elaborate the body -- that will happen as part of
1132         --  the library.
1133
1134         elsif Units.Table (Chosen).SAL_Interface then
1135            null;
1136
1137         else
1138            Choose
1139              (Elab_Order => Elab_Order,
1140               Chosen     => Corresponding_Body (Chosen),
1141               Msg        => " [Elaborate_Body]");
1142         end if;
1143      end if;
1144   end Choose;
1145
1146   ------------------------
1147   -- Corresponding_Body --
1148   ------------------------
1149
1150   --  Currently if the body and spec are separate, then they appear as two
1151   --  separate units in the same ALI file, with the body appearing first and
1152   --  the spec appearing second.
1153
1154   function Corresponding_Body (U : Unit_Id) return Unit_Id is
1155   begin
1156      pragma Assert (Units.Table (U).Utype = Is_Spec);
1157      return U - 1;
1158   end Corresponding_Body;
1159
1160   ------------------------
1161   -- Corresponding_Spec --
1162   ------------------------
1163
1164   --  Currently if the body and spec are separate, then they appear as two
1165   --  separate units in the same ALI file, with the body appearing first and
1166   --  the spec appearing second.
1167
1168   function Corresponding_Spec (U : Unit_Id) return Unit_Id is
1169   begin
1170      pragma Assert (Units.Table (U).Utype = Is_Body);
1171      return U + 1;
1172   end Corresponding_Spec;
1173
1174   --------------------
1175   -- Debug_Flag_Old --
1176   --------------------
1177
1178   function Debug_Flag_Old return Boolean is
1179   begin
1180      --  If the user specified both flags, we want to use the older algorithm,
1181      --  rather than some confusing mix of the two.
1182
1183      return Debug_Flag_P and not Debug_Flag_O;
1184   end Debug_Flag_Old;
1185
1186   ----------------------
1187   -- Debug_Flag_Older --
1188   ----------------------
1189
1190   function Debug_Flag_Older return Boolean is
1191   begin
1192      return Debug_Flag_O;
1193   end Debug_Flag_Older;
1194
1195   ----------------------------------
1196   -- Diagnose_Elaboration_Problem --
1197   ----------------------------------
1198
1199   procedure Diagnose_Elaboration_Problem
1200     (Elab_Order : in out Unit_Id_Table)
1201   is
1202      function Find_Path
1203        (Ufrom : Unit_Id;
1204         Uto   : Unit_Id;
1205         ML    : Nat) return Boolean;
1206      --  Recursive routine used to find a path from node Ufrom to node Uto.
1207      --  If a path exists, returns True and outputs an appropriate set of
1208      --  error messages giving the path. Also calls Choose for each of the
1209      --  nodes so that they get removed from the remaining set. There are
1210      --  two cases of calls, either Ufrom = Uto for an attempt to find a
1211      --  cycle, or Ufrom is a spec and Uto the corresponding body for the
1212      --  case of an unsatisfiable Elaborate_Body pragma. ML is the minimum
1213      --  acceptable length for a path.
1214
1215      ---------------
1216      -- Find_Path --
1217      ---------------
1218
1219      function Find_Path
1220        (Ufrom : Unit_Id;
1221         Uto   : Unit_Id;
1222         ML    : Nat) return Boolean
1223      is
1224         function Find_Link (U : Unit_Id; PL : Nat) return Boolean;
1225         --  This is the inner recursive routine, it determines if a path
1226         --  exists from U to Uto, and if so returns True and outputs the
1227         --  appropriate set of error messages. PL is the path length
1228
1229         ---------------
1230         -- Find_Link --
1231         ---------------
1232
1233         function Find_Link (U : Unit_Id; PL : Nat) return Boolean is
1234            S : Successor_Id;
1235
1236         begin
1237            --  Recursion ends if we are at terminating node and the path is
1238            --  sufficiently long, generate error message and return True.
1239
1240            if U = Uto and then PL >= ML then
1241               Choose (Elab_Order, U, " [Find_Link: base]");
1242               return True;
1243
1244            --  All done if already visited
1245
1246            elsif UNR.Table (U).Visited then
1247               return False;
1248
1249            --  Otherwise mark as visited and look at all successors
1250
1251            else
1252               UNR.Table (U).Visited := True;
1253
1254               S := UNR.Table (U).Successors;
1255               while S /= No_Successor loop
1256                  if Find_Link (Succ.Table (S).After, PL + 1) then
1257                     Elab_Error_Msg (S);
1258                     Choose (Elab_Order, U, " [Find_Link: recursive]");
1259                     return True;
1260                  end if;
1261
1262                  S := Succ.Table (S).Next;
1263               end loop;
1264
1265               --  Falling through means this does not lead to a path
1266
1267               return False;
1268            end if;
1269         end Find_Link;
1270
1271      --  Start of processing for Find_Path
1272
1273      begin
1274         --  Initialize all non-chosen nodes to not visited yet
1275
1276         for U in Units.First .. Units.Last loop
1277            UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0;
1278         end loop;
1279
1280         --  Now try to find the path
1281
1282         return Find_Link (Ufrom, 0);
1283      end Find_Path;
1284
1285   --  Start of processing for Diagnose_Elaboration_Problem
1286
1287   begin
1288      Diagnose_Elaboration_Problem_Called := True;
1289      Set_Standard_Error;
1290
1291      --  Output state of things if debug flag N set
1292
1293      if Debug_Flag_N then
1294         declare
1295            NP : Int;
1296
1297         begin
1298            Write_Eol;
1299            Write_Eol;
1300            Write_Line ("Diagnose_Elaboration_Problem called");
1301            Write_Line ("List of remaining unchosen units and predecessors");
1302
1303            for U in Units.First .. Units.Last loop
1304               if UNR.Table (U).Elab_Position = 0 then
1305                  NP := UNR.Table (U).Num_Pred;
1306                  Write_Eol;
1307                  Write_Str ("  Unchosen unit: #");
1308                  Write_Int (Int (U));
1309                  Write_Str ("  ");
1310                  Write_Unit_Name (Units.Table (U).Uname);
1311                  Write_Str (" (Num_Pred = ");
1312                  Write_Int (NP);
1313                  Write_Line (")");
1314
1315                  if NP = 0 then
1316                     if Units.Table (U).Elaborate_Body then
1317                        Write_Line
1318                          ("    (not chosen because of Elaborate_Body)");
1319                     else
1320                        Write_Line ("  ****************** why not chosen?");
1321                     end if;
1322                  end if;
1323
1324                  --  Search links list to find unchosen predecessors
1325
1326                  for S in Succ.First .. Succ.Last loop
1327                     declare
1328                        SL : Successor_Link renames Succ.Table (S);
1329
1330                     begin
1331                        if SL.After = U
1332                          and then UNR.Table (SL.Before).Elab_Position = 0
1333                        then
1334                           Write_Str ("    unchosen predecessor: #");
1335                           Write_Int (Int (SL.Before));
1336                           Write_Str ("  ");
1337                           Write_Unit_Name (Units.Table (SL.Before).Uname);
1338                           Write_Eol;
1339                           NP := NP - 1;
1340                        end if;
1341                     end;
1342                  end loop;
1343
1344                  if NP /= 0 then
1345                     Write_Line ("  **************** Num_Pred value wrong!");
1346                  end if;
1347               end if;
1348            end loop;
1349         end;
1350      end if;
1351
1352      --  Output the header for the error, and manually increment the error
1353      --  count. We are using Error_Msg_Output rather than Error_Msg here for
1354      --  two reasons:
1355
1356      --    This is really only one error, not one for each line
1357      --    We want this output on standard output since it is voluminous
1358
1359      --  But we do need to deal with the error count manually in this case
1360
1361      Errors_Detected := Errors_Detected + 1;
1362      Error_Msg_Output ("elaboration circularity detected", Info => False);
1363
1364      --  Try to find cycles starting with any of the remaining nodes that have
1365      --  not yet been chosen. There must be at least one (there is some reason
1366      --  we are being called).
1367
1368      for U in Units.First .. Units.Last loop
1369         if UNR.Table (U).Elab_Position = 0 then
1370            if Find_Path (U, U, 1) then
1371               raise Unrecoverable_Error;
1372            end if;
1373         end if;
1374      end loop;
1375
1376      --  We should never get here, since we were called for some reason, and
1377      --  we should have found and eliminated at least one bad path.
1378
1379      raise Program_Error;
1380   end Diagnose_Elaboration_Problem;
1381
1382   --------------------
1383   -- Elab_All_Links --
1384   --------------------
1385
1386   procedure Elab_All_Links
1387     (Before : Unit_Id;
1388      After  : Unit_Id;
1389      Reason : Succ_Reason;
1390      Link   : Elab_All_Id)
1391   is
1392   begin
1393      if UNR.Table (Before).Visited then
1394         return;
1395      end if;
1396
1397      --  Build the direct link for Before
1398
1399      UNR.Table (Before).Visited := True;
1400      Build_Link (Before, After, Reason, Link);
1401
1402      --  Process all units with'ed by Before recursively
1403
1404      for W in Units.Table (Before).First_With ..
1405               Units.Table (Before).Last_With
1406      loop
1407         --  Skip if this with is an interface to a stand-alone library. Skip
1408         --  also if no ALI file for this WITH, happens for language defined
1409         --  generics while bootstrapping the compiler (see body of routine
1410         --  Lib.Writ.Write_With_Lines). Finally, skip if it is a limited with
1411         --  clause, which does not impose an elaboration link.
1412
1413         if not Withs.Table (W).SAL_Interface
1414           and then Withs.Table (W).Afile /= No_File
1415           and then not Withs.Table (W).Limited_With
1416         then
1417            declare
1418               Info : constant Int :=
1419                 Get_Name_Table_Int (Withs.Table (W).Uname);
1420
1421            begin
1422               --  If the unit is unknown, for some unknown reason, fail
1423               --  graciously explaining that the unit is unknown. Without
1424               --  this check, gnatbind will crash in Unit_Id_Of.
1425
1426               if Info = 0 or else Unit_Id (Info) = No_Unit_Id then
1427                  declare
1428                     Withed       : String  :=
1429                                      Get_Name_String (Withs.Table (W).Uname);
1430                     Last_Withed  : Natural := Withed'Last;
1431                     Withing      : String  :=
1432                                      Get_Name_String
1433                                        (Units.Table (Before).Uname);
1434                     Last_Withing : Natural := Withing'Last;
1435                     Spec_Body    : String  := " (Spec)";
1436
1437                  begin
1438                     To_Mixed (Withed);
1439                     To_Mixed (Withing);
1440
1441                     if Last_Withed > 2
1442                       and then Withed (Last_Withed - 1) = '%'
1443                     then
1444                        Last_Withed := Last_Withed - 2;
1445                     end if;
1446
1447                     if Last_Withing > 2
1448                       and then Withing (Last_Withing - 1) = '%'
1449                     then
1450                        Last_Withing := Last_Withing - 2;
1451                     end if;
1452
1453                     if Units.Table (Before).Utype = Is_Body
1454                       or else Units.Table (Before).Utype = Is_Body_Only
1455                     then
1456                        Spec_Body := " (Body)";
1457                     end if;
1458
1459                     Osint.Fail
1460                       ("could not find unit "
1461                        & Withed (Withed'First .. Last_Withed) & " needed by "
1462                        & Withing (Withing'First .. Last_Withing) & Spec_Body);
1463                  end;
1464               end if;
1465
1466               Elab_All_Links
1467                 (Unit_Id_Of (Withs.Table (W).Uname),
1468                  After,
1469                  Reason,
1470                  Make_Elab_All_Entry (Withs.Table (W).Uname, Link));
1471            end;
1472         end if;
1473      end loop;
1474
1475      --  Process corresponding body, if there is one
1476
1477      if Units.Table (Before).Utype = Is_Spec then
1478         Elab_All_Links
1479           (Corresponding_Body (Before),
1480            After, Reason,
1481            Make_Elab_All_Entry
1482              (Units.Table (Corresponding_Body (Before)).Uname, Link));
1483      end if;
1484   end Elab_All_Links;
1485
1486   --------------------
1487   -- Elab_Error_Msg --
1488   --------------------
1489
1490   procedure Elab_Error_Msg (S : Successor_Id) is
1491      SL : Successor_Link renames Succ.Table (S);
1492
1493   begin
1494      --  Nothing to do if internal unit involved and no -da flag
1495
1496      if not Debug_Flag_A
1497        and then
1498          (Is_Internal_File_Name (Units.Table (SL.Before).Sfile)
1499            or else
1500           Is_Internal_File_Name (Units.Table (SL.After).Sfile))
1501      then
1502         return;
1503      end if;
1504
1505      --  Here we want to generate output
1506
1507      Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
1508
1509      if SL.Elab_Body then
1510         Error_Msg_Unit_2 := Units.Table (Corresponding_Body (SL.After)).Uname;
1511      else
1512         Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
1513      end if;
1514
1515      Error_Msg_Output ("  $ must be elaborated before $", Info => True);
1516
1517      Error_Msg_Unit_1 := Units.Table (SL.Reason_Unit).Uname;
1518
1519      case SL.Reason is
1520         when Withed =>
1521            Error_Msg_Output
1522              ("     reason: with clause",
1523               Info => True);
1524
1525         when Forced =>
1526            Error_Msg_Output
1527              ("     reason: forced by -f switch",
1528               Info => True);
1529
1530         when Elab =>
1531            Error_Msg_Output
1532              ("     reason: pragma Elaborate in unit $",
1533               Info => True);
1534
1535         when Elab_All =>
1536            Error_Msg_Output
1537              ("     reason: pragma Elaborate_All in unit $",
1538               Info => True);
1539
1540         when Elab_All_Desirable =>
1541            Error_Msg_Output
1542              ("     reason: implicit Elaborate_All in unit $",
1543               Info => True);
1544
1545            Error_Msg_Output
1546              ("     recompile $ with -gnatel for full details",
1547               Info => True);
1548
1549         when Elab_Desirable =>
1550            Error_Msg_Output
1551              ("     reason: implicit Elaborate in unit $",
1552               Info => True);
1553
1554            Error_Msg_Output
1555              ("     recompile $ with -gnatel for full details",
1556               Info => True);
1557
1558         when Spec_First =>
1559            Error_Msg_Output
1560              ("     reason: spec always elaborated before body",
1561               Info => True);
1562      end case;
1563
1564      Write_Elab_All_Chain (S);
1565
1566      if SL.Elab_Body then
1567         Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
1568         Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
1569         Error_Msg_Output
1570           ("  $ must therefore be elaborated before $", True);
1571
1572         Error_Msg_Unit_1 := Units.Table (SL.After).Uname;
1573         Error_Msg_Output
1574           ("     (because $ has a pragma Elaborate_Body)", True);
1575      end if;
1576
1577      if not Zero_Formatting then
1578         Write_Eol;
1579      end if;
1580   end Elab_Error_Msg;
1581
1582   ---------------------
1583   -- Find_Elab_Order --
1584   ---------------------
1585
1586   procedure Find_Elab_Order
1587     (Elab_Order          : out Unit_Id_Table;
1588      First_Main_Lib_File : File_Name_Type)
1589   is
1590      function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat;
1591      --  Number of cases where the body of a unit immediately follows the
1592      --  corresponding spec. Such cases are good, because calls to that unit
1593      --  from outside can't get ABE.
1594
1595      -------------------------
1596      -- Num_Spec_Body_Pairs --
1597      -------------------------
1598
1599      function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat is
1600         Result : Nat := 0;
1601
1602      begin
1603         for J in Order'First + 1 .. Order'Last loop
1604            if Units.Table (Order (J - 1)).Utype = Is_Spec
1605              and then Units.Table (Order (J)).Utype = Is_Body
1606              and then Corresponding_Spec (Order (J)) = Order (J - 1)
1607            then
1608               Result := Result + 1;
1609            end if;
1610         end loop;
1611
1612         return Result;
1613      end Num_Spec_Body_Pairs;
1614
1615      --  Local variables
1616
1617      Old_Elab_Order : Unit_Id_Table;
1618
1619   --  Start of processing for Find_Elab_Order
1620
1621   begin
1622      --  Output warning if -p used with no -gnatE units
1623
1624      if Pessimistic_Elab_Order
1625        and not Dynamic_Elaboration_Checks_Specified
1626      then
1627         Error_Msg ("?use of -p switch questionable");
1628         Error_Msg ("?since all units compiled with static elaboration model");
1629      end if;
1630
1631      if Do_New and not Debug_Flag_Old and not Debug_Flag_Older then
1632         if Debug_Flag_V then
1633            Write_Line ("Doing new...");
1634         end if;
1635
1636         Doing_New := True;
1637         Init;
1638         Elab_New.Find_Elab_Order (Elab_Order);
1639      end if;
1640
1641      --  Elab_New does not support the pessimistic order, so if that was
1642      --  requested, use the old results. Use Elab_Old if -dp or -do was
1643      --  selected. Elab_New does not yet give proper error messages for
1644      --  illegal Elaborate_Alls, so if there is one, run Elab_Old.
1645
1646      if Do_Old
1647        or Pessimistic_Elab_Order
1648        or Debug_Flag_Old
1649        or Debug_Flag_Older
1650        or Elab_Cycle_Found
1651      then
1652         if Debug_Flag_V then
1653            Write_Line ("Doing old...");
1654         end if;
1655
1656         Doing_New := False;
1657         Init;
1658         Elab_Old.Find_Elab_Order (Old_Elab_Order);
1659      end if;
1660
1661      pragma Assert (Elab_Cycle_Found <= -- implies
1662                       Diagnose_Elaboration_Problem_Called);
1663
1664      declare
1665         Old_Order : Unit_Id_Array renames
1666                       Old_Elab_Order.Table (1 .. Last (Old_Elab_Order));
1667      begin
1668         if Do_Old and Do_New then
1669            declare
1670               New_Order : Unit_Id_Array renames
1671                             Elab_Order.Table (1 .. Last (Elab_Order));
1672               Old_Pairs : constant Nat := Num_Spec_Body_Pairs (Old_Order);
1673               New_Pairs : constant Nat := Num_Spec_Body_Pairs (New_Order);
1674
1675            begin
1676               Write_Line (Get_Name_String (First_Main_Lib_File));
1677
1678               pragma Assert (Old_Order'Length = New_Order'Length);
1679               pragma Debug (Validate (Old_Order, Doing_New => False));
1680               pragma Debug (Validate (New_Order, Doing_New => True));
1681
1682               --  Misc debug printouts that can be used for experimentation by
1683               --  changing the 'if's below.
1684
1685               if True then
1686                  if New_Order = Old_Order then
1687                     Write_Line ("Elab_New: same order.");
1688                  else
1689                     Write_Line ("Elab_New: diff order.");
1690                  end if;
1691               end if;
1692
1693               if New_Order /= Old_Order and then False then
1694                  Write_Line ("Elaboration orders differ:");
1695                  Write_Elab_Order
1696                    (Old_Order, Title => "OLD ELABORATION ORDER");
1697                  Write_Elab_Order
1698                    (New_Order, Title => "NEW ELABORATION ORDER");
1699               end if;
1700
1701               if True then
1702                  Write_Str ("Pairs: ");
1703                  Write_Int (Old_Pairs);
1704
1705                  if Old_Pairs = New_Pairs then
1706                     Write_Str (" = ");
1707                  elsif Old_Pairs < New_Pairs then
1708                     Write_Str (" < ");
1709                  else
1710                     Write_Str (" > ");
1711                  end if;
1712
1713                  Write_Int (New_Pairs);
1714                  Write_Eol;
1715               end if;
1716
1717               if Old_Pairs /= New_Pairs and then False then
1718                  Write_Str ("Pairs: ");
1719                  Write_Int (Old_Pairs);
1720
1721                  if Old_Pairs < New_Pairs then
1722                     Write_Str (" < ");
1723                  else
1724                     Write_Str (" > ");
1725                  end if;
1726
1727                  Write_Int (New_Pairs);
1728                  Write_Eol;
1729
1730                  if Old_Pairs /= New_Pairs and then Debug_Flag_V then
1731                     Write_Elab_Order
1732                       (Old_Order, Title => "OLD ELABORATION ORDER");
1733                     Write_Elab_Order
1734                       (New_Order, Title => "NEW ELABORATION ORDER");
1735                     pragma Assert (New_Pairs >= Old_Pairs);
1736                  end if;
1737               end if;
1738            end;
1739         end if;
1740
1741         --  The Elab_New algorithm doesn't implement the -p switch, so if that
1742         --  was used, use the results from the old algorithm. Likewise if the
1743         --  user has requested the old algorithm.
1744
1745         if Pessimistic_Elab_Order or Debug_Flag_Old or Debug_Flag_Older then
1746            pragma Assert
1747              (Last (Elab_Order) = 0
1748                or else Last (Elab_Order) = Old_Order'Last);
1749
1750            Init (Elab_Order);
1751            Append_All (Elab_Order, Old_Order);
1752         end if;
1753
1754         --  Now set the Elab_Positions in the Units table. It is important to
1755         --  do this late, in case we're running both Elab_New and Elab_Old.
1756
1757         declare
1758            New_Order : Unit_Id_Array renames
1759                          Elab_Order.Table (1 .. Last (Elab_Order));
1760            Units_Array : Units.Table_Type renames
1761                            Units.Table (Units.First .. Units.Last);
1762         begin
1763            for J in New_Order'Range loop
1764               pragma Assert
1765                 (UNR.Table (New_Order (J)).Elab_Position = J);
1766               Units_Array  (New_Order (J)).Elab_Position := J;
1767            end loop;
1768
1769            if Errors_Detected = 0 then
1770
1771               --  Display elaboration order if -l was specified
1772
1773               if Elab_Order_Output then
1774                  if Zero_Formatting then
1775                     Write_Elab_Order (New_Order, Title => "");
1776                  else
1777                     Write_Elab_Order
1778                       (New_Order, Title => "ELABORATION ORDER");
1779                  end if;
1780               end if;
1781
1782               --  Display list of sources in the closure (except predefined
1783               --  sources) if -R was used. Include predefined sources if -Ra
1784               --  was used.
1785
1786               if List_Closure then
1787                  Write_Closure (New_Order);
1788               end if;
1789            end if;
1790         end;
1791      end;
1792   end Find_Elab_Order;
1793
1794   ----------------------
1795   -- Force_Elab_Order --
1796   ----------------------
1797
1798   procedure Force_Elab_Order is
1799      subtype Header_Num is Unit_Name_Type'Base range 0 .. 2**16 - 1;
1800
1801      function Hash (N : Unit_Name_Type) return Header_Num;
1802
1803      package Name_Map is new System.HTable.Simple_HTable
1804        (Header_Num => Header_Num,
1805         Element    => Logical_Line_Number,
1806         No_Element => No_Line_Number,
1807         Key        => Unit_Name_Type,
1808         Hash       => Hash,
1809         Equal      => "=");
1810      --  Name_Map contains an entry for each file name seen, mapped to the
1811      --  line number where we saw it first. This is used to give an error for
1812      --  duplicates.
1813
1814      ----------
1815      -- Hash --
1816      ----------
1817
1818      function Hash (N : Unit_Name_Type) return Header_Num is
1819         --  Name_Ids are already widely dispersed; no need for any actual
1820         --  hashing. Just subtract to make it zero based, and "mod" to
1821         --  bring it in range.
1822      begin
1823         return (N - Unit_Name_Type'First) mod (Header_Num'Last + 1);
1824      end Hash;
1825
1826      --  Local variables
1827
1828      Cur_Line_Number : Logical_Line_Number;
1829      Error           : Boolean := False;
1830      Iter            : Forced_Units_Iterator;
1831      Prev_Unit       : Unit_Id := No_Unit_Id;
1832      Uname           : Unit_Name_Type;
1833
1834   --  Start of processing for Force_Elab_Order
1835
1836   begin
1837      Iter := Iterate_Forced_Units;
1838      while Has_Next (Iter) loop
1839         Next (Iter, Uname, Cur_Line_Number);
1840
1841         declare
1842            Dup : constant Logical_Line_Number := Name_Map.Get (Uname);
1843         begin
1844            if Dup = No_Line_Number then
1845               Name_Map.Set (Uname, Cur_Line_Number);
1846
1847               --  We don't need to give the "not present" message in the case
1848               --  of "duplicate unit", because we would have already given the
1849               --  "not present" message on the first occurrence.
1850
1851               if Get_Name_Table_Int (Uname) = 0
1852                 or else Unit_Id (Get_Name_Table_Int (Uname)) = No_Unit_Id
1853               then
1854                  Error := True;
1855                  if Doing_New then
1856                     Write_Line
1857                       ("""" & Get_Name_String (Uname)
1858                        & """: not present; ignored");
1859                  end if;
1860               end if;
1861
1862            else
1863               Error := True;
1864               if Doing_New then
1865                  Error_Msg_Nat_1  := Nat (Cur_Line_Number);
1866                  Error_Msg_Unit_1 := Uname;
1867                  Error_Msg_Nat_2  := Nat (Dup);
1868                  Error_Msg
1869                    (Force_Elab_Order_File.all
1870                     & ":#: duplicate unit name $ from line #");
1871               end if;
1872            end if;
1873         end;
1874
1875         if not Error then
1876            declare
1877               Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname);
1878            begin
1879               if Is_Internal_File_Name (Units.Table (Cur_Unit).Sfile) then
1880                  if Doing_New then
1881                     Write_Line
1882                       ("""" & Get_Name_String (Uname)
1883                        & """: predefined unit ignored");
1884                  end if;
1885
1886               else
1887                  if Prev_Unit /= No_Unit_Id then
1888                     if Doing_New then
1889                        Write_Unit_Name (Units.Table (Prev_Unit).Uname);
1890                        Write_Str (" <-- ");
1891                        Write_Unit_Name (Units.Table (Cur_Unit).Uname);
1892                        Write_Eol;
1893                     end if;
1894
1895                     Build_Link
1896                       (Before => Prev_Unit,
1897                        After  => Cur_Unit,
1898                        R      => Forced);
1899                  end if;
1900
1901                  Prev_Unit := Cur_Unit;
1902               end if;
1903            end;
1904         end if;
1905      end loop;
1906   end Force_Elab_Order;
1907
1908   -------------------------
1909   -- Gather_Dependencies --
1910   -------------------------
1911
1912   procedure Gather_Dependencies is
1913      Withed_Unit : Unit_Id;
1914
1915   begin
1916      --  Loop through all units
1917
1918      for U in Units.First .. Units.Last loop
1919         Cur_Unit := U;
1920
1921         --  If this is not an interface to a stand-alone library and there is
1922         --  a body and a spec, then spec must be elaborated first. Note that
1923         --  the corresponding spec immediately follows the body.
1924
1925         if not Units.Table (U).SAL_Interface
1926           and then Units.Table (U).Utype = Is_Body
1927         then
1928            Build_Link (Corresponding_Spec (U), U, Spec_First);
1929         end if;
1930
1931         --  If this unit is not an interface to a stand-alone library, process
1932         --  WITH references for this unit ignoring interfaces to stand-alone
1933         --  libraries.
1934
1935         if not Units.Table (U).SAL_Interface then
1936            for W in Units.Table (U).First_With ..
1937                     Units.Table (U).Last_With
1938            loop
1939               if Withs.Table (W).Sfile /= No_File
1940                 and then (not Withs.Table (W).SAL_Interface)
1941               then
1942                  --  Check for special case of withing a unit that does not
1943                  --  exist any more. If the unit was completely missing we
1944                  --  would already have detected this, but a nasty case arises
1945                  --  when we have a subprogram body with no spec, and some
1946                  --  obsolete unit with's a previous (now disappeared) spec.
1947
1948                  if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then
1949                     if Doing_New then
1950                        Error_Msg_File_1 := Units.Table (U).Sfile;
1951                        Error_Msg_Unit_1 := Withs.Table (W).Uname;
1952                        Error_Msg ("{ depends on $ which no longer exists");
1953                     end if;
1954
1955                     goto Next_With;
1956                  end if;
1957
1958                  Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname);
1959
1960                  --  Pragma Elaborate_All case, for this we use the recursive
1961                  --  Elab_All_Links procedure to establish the links.
1962
1963                  --  Elab_New ignores Elaborate_All and Elab_All_Desirable,
1964                  --  except for error messages.
1965
1966                  if Withs.Table (W).Elaborate_All and then not Doing_New then
1967
1968                     --  Reset flags used to stop multiple visits to a given
1969                     --  node.
1970
1971                     for Uref in UNR.First .. UNR.Last loop
1972                        UNR.Table (Uref).Visited := False;
1973                     end loop;
1974
1975                     --  Now establish all the links we need
1976
1977                     Elab_All_Links
1978                       (Withed_Unit, U, Elab_All,
1979                        Make_Elab_All_Entry
1980                          (Withs.Table (W).Uname, No_Elab_All_Link));
1981
1982                  --  Elaborate_All_Desirable case, for this we establish the
1983                  --  same links as above, but with a different reason.
1984
1985                  elsif Withs.Table (W).Elab_All_Desirable
1986                    and then not Doing_New
1987                  then
1988                     --  Reset flags used to stop multiple visits to a given
1989                     --  node.
1990
1991                     for Uref in UNR.First .. UNR.Last loop
1992                        UNR.Table (Uref).Visited := False;
1993                     end loop;
1994
1995                     --  Now establish all the links we need
1996
1997                     Elab_All_Links
1998                       (Withed_Unit, U, Elab_All_Desirable,
1999                        Make_Elab_All_Entry
2000                          (Withs.Table (W).Uname, No_Elab_All_Link));
2001
2002                  --  Pragma Elaborate case. We must build a link for the
2003                  --  withed unit itself, and also the corresponding body if
2004                  --  there is one.
2005
2006                  --  However, skip this processing if there is no ALI file for
2007                  --  the WITH entry, because this means it is a generic (even
2008                  --  when we fix the generics so that an ALI file is present,
2009                  --  we probably still will have no ALI file for unchecked and
2010                  --  other special cases).
2011
2012                  elsif Withs.Table (W).Elaborate
2013                    and then Withs.Table (W).Afile /= No_File
2014                  then
2015                     Build_Link (Withed_Unit, U, Withed);
2016
2017                     if Units.Table (Withed_Unit).Utype = Is_Spec then
2018                        Build_Link
2019                          (Corresponding_Body (Withed_Unit), U, Elab);
2020                     end if;
2021
2022                  --  Elaborate_Desirable case, for this we establish the same
2023                  --  links as above, but with a different reason.
2024
2025                  elsif Withs.Table (W).Elab_Desirable then
2026                     Build_Link (Withed_Unit, U, Withed);
2027
2028                     if Units.Table (Withed_Unit).Utype = Is_Spec then
2029                        Build_Link
2030                          (Corresponding_Body (Withed_Unit),
2031                           U, Elab_Desirable);
2032                     end if;
2033
2034                  --  A limited_with does not establish an elaboration
2035                  --  dependence (that's the whole point).
2036
2037                  elsif Withs.Table (W).Limited_With then
2038                     null;
2039
2040                  --  Case of normal WITH with no elaboration pragmas, just
2041                  --  build the single link to the directly referenced unit
2042
2043                  else
2044                     Build_Link (Withed_Unit, U, Withed);
2045                  end if;
2046               end if;
2047
2048               <<Next_With>>
2049               null;
2050            end loop;
2051         end if;
2052      end loop;
2053
2054      --  If -f<elab_order> switch was given, take into account dependences
2055      --  specified in the file <elab_order>.
2056
2057      if Force_Elab_Order_File /= null then
2058         Force_Elab_Order;
2059      end if;
2060
2061      --  Output elaboration dependencies if option is set
2062
2063      if Elab_Dependency_Output or Debug_Flag_E then
2064         if Doing_New then
2065            Write_Dependencies;
2066         end if;
2067      end if;
2068   end Gather_Dependencies;
2069
2070   ----------
2071   -- Init --
2072   ----------
2073
2074   procedure Init is
2075   begin
2076      Num_Chosen := 0;
2077      Num_Left := Int (Units.Last - Units.First + 1);
2078      Succ.Init;
2079      Elab_All_Entries.Init;
2080      UNR.Init;
2081
2082      --  Initialize unit table for elaboration control
2083
2084      for U in Units.First .. Units.Last loop
2085         UNR.Append
2086           ((Successors    => No_Successor,
2087             Num_Pred      => 0,
2088             Nextnp        => No_Unit_Id,
2089             Visited       => False,
2090             Elab_Position => 0,
2091             SCC_Root      => No_Unit_Id,
2092             Nodes         => null,
2093             SCC_Num_Pred  => 0,
2094             Validate_Seen => False));
2095      end loop;
2096   end Init;
2097
2098   ------------------
2099   -- Is_Body_Unit --
2100   ------------------
2101
2102   function Is_Body_Unit (U : Unit_Id) return Boolean is
2103   begin
2104      return
2105        Units.Table (U).Utype = Is_Body
2106          or else Units.Table (U).Utype = Is_Body_Only;
2107   end Is_Body_Unit;
2108
2109   -----------------------------
2110   -- Is_Pure_Or_Preelab_Unit --
2111   -----------------------------
2112
2113   function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean is
2114   begin
2115      --  If we have a body with separate spec, test flags on the spec
2116
2117      if Units.Table (U).Utype = Is_Body then
2118         return
2119           Units.Table (Corresponding_Spec (U)).Preelab
2120             or else Units.Table (Corresponding_Spec (U)).Pure;
2121
2122      --  Otherwise we have a spec or body acting as spec, test flags on unit
2123
2124      else
2125         return Units.Table (U).Preelab or else Units.Table (U).Pure;
2126      end if;
2127   end Is_Pure_Or_Preelab_Unit;
2128
2129   ---------------------
2130   -- Is_Waiting_Body --
2131   ---------------------
2132
2133   function Is_Waiting_Body (U : Unit_Id) return Boolean is
2134   begin
2135      return
2136        Units.Table (U).Utype = Is_Body
2137          and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
2138   end Is_Waiting_Body;
2139
2140   -------------------------
2141   -- Make_Elab_All_Entry --
2142   -------------------------
2143
2144   function Make_Elab_All_Entry
2145     (Unam : Unit_Name_Type;
2146      Link : Elab_All_Id) return Elab_All_Id
2147   is
2148   begin
2149      Elab_All_Entries.Append ((Needed_By => Unam, Next_Elab => Link));
2150      return Elab_All_Entries.Last;
2151   end Make_Elab_All_Entry;
2152
2153   ----------------
2154   -- Unit_Id_Of --
2155   ----------------
2156
2157   function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
2158      Info : constant Int := Get_Name_Table_Int (Uname);
2159
2160   begin
2161      pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
2162      return Unit_Id (Info);
2163   end Unit_Id_Of;
2164
2165   --------------
2166   -- Validate --
2167   --------------
2168
2169   procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean) is
2170      Cur_SCC : Unit_Id := No_Unit_Id;
2171      OK      : Boolean := True;
2172      Msg     : String := "Old: ";
2173
2174   begin
2175      if Doing_New then
2176         Msg := "New: ";
2177      end if;
2178
2179      --  For each unit, assert that its successors are elaborated after it
2180
2181      for J in Order'Range loop
2182         declare
2183            U : constant Unit_Id := Order (J);
2184            S : Successor_Id := UNR.Table (U).Successors;
2185
2186         begin
2187            while S /= No_Successor loop
2188               if UNR.Table (Succ.Table (S).After).Elab_Position <=
2189                    UNR.Table (U).Elab_Position
2190               then
2191                  OK := False;
2192                  Write_Line (Msg & " elab order failed");
2193               end if;
2194
2195               S := Succ.Table (S).Next;
2196            end loop;
2197         end;
2198      end loop;
2199
2200      --  An SCC of size 2 units necessarily consists of a spec and the
2201      --  corresponding body. Assert that the body is elaborated immediately
2202      --  after the spec, with nothing in between. (We only have SCCs in the
2203      --  new algorithm.)
2204
2205      if Doing_New then
2206         for J in Order'Range loop
2207            declare
2208               U : constant Unit_Id := Order (J);
2209
2210            begin
2211               if Nodes (U)'Length = 2 then
2212                  if Units.Table (U).Utype = Is_Spec then
2213                     if Order (J + 1) /= Corresponding_Body (U) then
2214                        OK := False;
2215                        Write_Line (Msg & "Bad spec with SCC of size 2:");
2216                        Write_SCC (SCC (U));
2217                     end if;
2218                  end if;
2219
2220                  if Units.Table (U).Utype = Is_Body then
2221                     if Order (J - 1) /= Corresponding_Spec (U) then
2222                        OK := False;
2223                        Write_Line (Msg & "Bad body with SCC of size 2:");
2224                        Write_SCC (SCC (U));
2225                     end if;
2226                  end if;
2227               end if;
2228            end;
2229         end loop;
2230
2231         --  Assert that all units of an SCC are elaborated together, with no
2232         --  units from other SCCs in between. The above spec/body case is a
2233         --  special case of this general rule.
2234
2235         for J in Order'Range loop
2236            declare
2237               U : constant Unit_Id := Order (J);
2238
2239            begin
2240               if SCC (U) /= Cur_SCC then
2241                  Cur_SCC := SCC (U);
2242                  if UNR.Table (Cur_SCC).Validate_Seen then
2243                     OK := False;
2244                     Write_Line (Msg & "SCC not elaborated together:");
2245                     Write_SCC (Cur_SCC);
2246                  end if;
2247
2248                  UNR.Table (Cur_SCC).Validate_Seen := True;
2249               end if;
2250            end;
2251         end loop;
2252      end if;
2253
2254      pragma Assert (OK);
2255   end Validate;
2256
2257   -------------------
2258   -- Write_Closure --
2259   -------------------
2260
2261   procedure Write_Closure (Order : Unit_Id_Array) is
2262      package Closure_Sources is new Table.Table
2263        (Table_Component_Type => File_Name_Type,
2264         Table_Index_Type     => Natural,
2265         Table_Low_Bound      => 1,
2266         Table_Initial        => 10,
2267         Table_Increment      => 100,
2268         Table_Name           => "Gnatbind.Closure_Sources");
2269      --  Table to record the sources in the closure, to avoid duplications
2270
2271      function Put_In_Sources (S : File_Name_Type) return Boolean;
2272      --  Check if S is already in table Sources and put in Sources if it is
2273      --  not. Return False if the source is already in Sources, and True if
2274      --  it is added.
2275
2276      --------------------
2277      -- Put_In_Sources --
2278      --------------------
2279
2280      function Put_In_Sources (S : File_Name_Type) return Boolean is
2281      begin
2282         for J in 1 .. Closure_Sources.Last loop
2283            if Closure_Sources.Table (J) = S then
2284               return False;
2285            end if;
2286         end loop;
2287
2288         Closure_Sources.Append (S);
2289         return True;
2290      end Put_In_Sources;
2291
2292      --  Local variables
2293
2294      Source : File_Name_Type;
2295
2296   --  Start of processing for Write_Closure
2297
2298   begin
2299      Closure_Sources.Init;
2300
2301      if not Zero_Formatting then
2302         Write_Eol;
2303         Write_Line ("REFERENCED SOURCES");
2304      end if;
2305
2306      for J in reverse Order'Range loop
2307         Source := Units.Table (Order (J)).Sfile;
2308
2309         --  Do not include same source more than once
2310
2311         if Put_In_Sources (Source)
2312
2313           --  Do not include run-time units unless -Ra switch set
2314
2315           and then (List_Closure_All
2316                      or else not Is_Internal_File_Name (Source))
2317         then
2318            if not Zero_Formatting then
2319               Write_Str ("   ");
2320            end if;
2321
2322            Write_Line (Get_Name_String (Source));
2323         end if;
2324      end loop;
2325
2326      --  Subunits do not appear in the elaboration table because they are
2327      --  subsumed by their parent units, but we need to list them for other
2328      --  tools. For now they are listed after other files, rather than right
2329      --  after their parent, since there is no easy link between the
2330      --  elaboration table and the ALIs table ??? As subunits may appear
2331      --  repeatedly in the list, if the parent unit appears in the context of
2332      --  several units in the closure, duplicates are suppressed.
2333
2334      for J in Sdep.First .. Sdep.Last loop
2335         Source := Sdep.Table (J).Sfile;
2336
2337         if Sdep.Table (J).Subunit_Name /= No_Name
2338           and then Put_In_Sources (Source)
2339           and then not Is_Internal_File_Name (Source)
2340         then
2341            if not Zero_Formatting then
2342               Write_Str ("   ");
2343            end if;
2344
2345            Write_Line (Get_Name_String (Source));
2346         end if;
2347      end loop;
2348
2349      if not Zero_Formatting then
2350         Write_Eol;
2351      end if;
2352   end Write_Closure;
2353
2354   ------------------------
2355   -- Write_Dependencies --
2356   ------------------------
2357
2358   procedure Write_Dependencies is
2359   begin
2360      if not Zero_Formatting then
2361         Write_Eol;
2362         Write_Line ("                 ELABORATION ORDER DEPENDENCIES");
2363         Write_Eol;
2364      end if;
2365
2366      Info_Prefix_Suppress := True;
2367
2368      for S in Succ_First .. Succ.Last loop
2369         Elab_Error_Msg (S);
2370      end loop;
2371
2372      Info_Prefix_Suppress := False;
2373
2374      if not Zero_Formatting then
2375         Write_Eol;
2376      end if;
2377   end Write_Dependencies;
2378
2379   --------------------------
2380   -- Write_Elab_All_Chain --
2381   --------------------------
2382
2383   procedure Write_Elab_All_Chain (S : Successor_Id) is
2384      ST     : constant Successor_Link := Succ.Table (S);
2385      After  : constant Unit_Name_Type := Units.Table (ST.After).Uname;
2386
2387      L   : Elab_All_Id;
2388      Nam : Unit_Name_Type;
2389
2390      First_Name : Boolean := True;
2391
2392   begin
2393      if ST.Reason in Elab_All .. Elab_All_Desirable then
2394         L := ST.Elab_All_Link;
2395         pragma Annotate (CodePeer, Modified, L);
2396
2397         while L /= No_Elab_All_Link loop
2398            Nam := Elab_All_Entries.Table (L).Needed_By;
2399            Error_Msg_Unit_1 := Nam;
2400            Error_Msg_Output ("        $", Info => True);
2401
2402            Get_Name_String (Nam);
2403
2404            if Name_Buffer (Name_Len) = 'b' then
2405               if First_Name then
2406                  Error_Msg_Output
2407                    ("           must be elaborated along with its spec:",
2408                     Info => True);
2409
2410               else
2411                  Error_Msg_Output
2412                    ("           which must be elaborated along with its "
2413                     & "spec:",
2414                     Info => True);
2415               end if;
2416
2417            else
2418               if First_Name then
2419                  Error_Msg_Output
2420                    ("           is withed by:",
2421                     Info => True);
2422
2423               else
2424                  Error_Msg_Output
2425                    ("           which is withed by:",
2426                     Info => True);
2427               end if;
2428            end if;
2429
2430            First_Name := False;
2431
2432            L := Elab_All_Entries.Table (L).Next_Elab;
2433         end loop;
2434
2435         Error_Msg_Unit_1 := After;
2436         Error_Msg_Output ("        $", Info => True);
2437      end if;
2438   end Write_Elab_All_Chain;
2439
2440   ----------------------
2441   -- Write_Elab_Order --
2442   ----------------------
2443
2444   procedure Write_Elab_Order
2445     (Order : Unit_Id_Array; Title : String)
2446   is
2447   begin
2448      if Title /= "" then
2449         Write_Eol;
2450         Write_Line (Title);
2451      end if;
2452
2453      for J in Order'Range loop
2454         if not Units.Table (Order (J)).SAL_Interface then
2455            if not Zero_Formatting then
2456               Write_Str ("   ");
2457            end if;
2458
2459            Write_Unit_Name (Units.Table (Order (J)).Uname);
2460            Write_Eol;
2461         end if;
2462      end loop;
2463
2464      if Title /= "" then
2465         Write_Eol;
2466      end if;
2467   end Write_Elab_Order;
2468
2469   --------------
2470   -- Elab_New --
2471   --------------
2472
2473   package body Elab_New is
2474
2475      generic
2476         type Node is (<>);
2477         First_Node : Node;
2478         Last_Node  : Node;
2479         type Node_Array is array (Pos range <>) of Node;
2480         with function Successors (N : Node) return Node_Array;
2481         with procedure Create_SCC (Root : Node; Nodes : Node_Array);
2482
2483      procedure Compute_Strongly_Connected_Components;
2484      --  Compute SCCs for a directed graph. The nodes in the graph are all
2485      --  values of type Node in the range First_Node .. Last_Node.
2486      --  Successors(N) returns the nodes pointed to by the edges emanating
2487      --  from N. Create_SCC is a callback that is called once for each SCC,
2488      --  passing in the Root node for that SCC (which is an arbitrary node in
2489      --  the SCC used as a representative of that SCC), and the set of Nodes
2490      --  in that SCC.
2491      --
2492      --  This is generic, in case we want to use it elsewhere; then we could
2493      --  move this into a separate library unit. Unfortunately, it's not as
2494      --  generic as one might like. Ideally, we would have "type Node is
2495      --  private;", and pass in iterators to iterate over all nodes, and over
2496      --  the successors of a given node. However, that leads to using advanced
2497      --  features of Ada that are not allowed in the compiler and binder for
2498      --  bootstrapping reasons. It also leads to trampolines, which are not
2499      --  allowed in the compiler and binder. Restricting Node to be discrete
2500      --  allows us to iterate over all nodes with a 'for' loop, and allows us
2501      --  to attach temporary information to nodes by having an array indexed
2502      --  by Node.
2503
2504      procedure Compute_Unit_SCCs;
2505      --  Use the above generic procedure to compute the SCCs for the graph of
2506      --  units. Store in each Unit_Node_Record the SCC_Root and Nodes
2507      --  components. Also initialize the SCC_Num_Pred components.
2508
2509      procedure Find_Elab_All_Errors;
2510      --  Generate an error for illegal Elaborate_All pragmas (explicit or
2511      --  implicit). A pragma Elaborate_All (Y) on unit X is legal if and only
2512      --  if X and Y are in different SCCs.
2513
2514      -------------------------------------------
2515      -- Compute_Strongly_Connected_Components --
2516      -------------------------------------------
2517
2518      procedure Compute_Strongly_Connected_Components is
2519
2520         --  This uses Tarjan's algorithm for finding SCCs. Comments here are
2521         --  intended to tell what it does, but if you want to know how it
2522         --  works, you have to look it up. Please do not modify this code
2523         --  without reading up on Tarjan's algorithm.
2524
2525         subtype Node_Index is Nat;
2526         No_Index : constant Node_Index := 0;
2527
2528         Num_Nodes : constant Nat :=
2529                       Node'Pos (Last_Node) - Node'Pos (First_Node) + 1;
2530         Stack : Node_Array (1 .. Num_Nodes);
2531         Top   : Node_Index := 0;
2532         --  Stack of nodes, pushed when first visited. All nodes of an SCC are
2533         --  popped at once when the SCC is found.
2534
2535         subtype Valid_Node is Node range First_Node .. Last_Node;
2536         Node_Indices : array (Valid_Node) of Node_Index :=
2537                          (others => No_Index);
2538         --  Each node has an "index", which is the sequential number in the
2539         --  order in which they are visited in the recursive walk. No_Index
2540         --  means "not yet visited"; we want to avoid walking any node more
2541         --  than once.
2542
2543         Index : Node_Index := 1;
2544         --  Next value to be assigned to a node index
2545
2546         Low_Links : array (Valid_Node) of Node_Index;
2547         --  Low_Links (N) is the smallest index of nodes reachable from N
2548
2549         On_Stack : array (Valid_Node) of Boolean := (others => False);
2550         --  True if the node is currently on the stack
2551
2552         procedure Walk (N : Valid_Node);
2553         --  Recursive depth-first graph walk, with the node index used to
2554         --  avoid visiting a node more than once.
2555
2556         ----------
2557         -- Walk --
2558         ----------
2559
2560         procedure Walk (N : Valid_Node) is
2561            Stack_Position_Of_N : constant Pos := Top + 1;
2562            S : constant Node_Array := Successors (N);
2563
2564         begin
2565            --  Assign the index and low link, increment Index for next call to
2566            --  Walk.
2567
2568            Node_Indices (N) := Index;
2569            Low_Links (N) := Index;
2570            Index := Index + 1;
2571
2572            --  Push it on the stack:
2573
2574            Top := Stack_Position_Of_N;
2575            Stack (Top) := N;
2576            On_Stack (N) := True;
2577
2578            --  Walk not-yet-visited subnodes, and update low link for visited
2579            --  ones as appropriate.
2580
2581            for J in S'Range loop
2582               if Node_Indices (S (J)) = No_Index then
2583                  Walk (S (J));
2584                  Low_Links (N) :=
2585                    Node_Index'Min (Low_Links (N), Low_Links (S (J)));
2586               elsif On_Stack (S (J)) then
2587                  Low_Links (N) :=
2588                    Node_Index'Min (Low_Links (N), Node_Indices (S (J)));
2589               end if;
2590            end loop;
2591
2592            --  If the index is (still) equal to the low link, we've found an
2593            --  SCC. Pop the whole SCC off the stack, and call Create_SCC.
2594
2595            if Low_Links (N) = Node_Indices (N) then
2596               declare
2597                  SCC : Node_Array renames
2598                    Stack (Stack_Position_Of_N .. Top);
2599                  pragma Assert (SCC'Length >= 1);
2600                  pragma Assert (SCC (SCC'First) = N);
2601
2602               begin
2603                  for J in SCC'Range loop
2604                     On_Stack (SCC (J)) := False;
2605                  end loop;
2606
2607                  Create_SCC (Root => N, Nodes => SCC);
2608                  pragma Assert (Top - SCC'Length = Stack_Position_Of_N - 1);
2609                  Top := Stack_Position_Of_N - 1; -- pop all
2610               end;
2611            end if;
2612         end Walk;
2613
2614      --  Start of processing for Compute_Strongly_Connected_Components
2615
2616      begin
2617         --  Walk all the nodes that have not yet been walked
2618
2619         for N in Valid_Node loop
2620            if Node_Indices (N) = No_Index then
2621               Walk (N);
2622            end if;
2623         end loop;
2624      end Compute_Strongly_Connected_Components;
2625
2626      -----------------------
2627      -- Compute_Unit_SCCs --
2628      -----------------------
2629
2630      procedure Compute_Unit_SCCs is
2631         function Successors (U : Unit_Id) return Unit_Id_Array;
2632         --  Return all the units that must be elaborated after U. In addition,
2633         --  if U is a body, include the corresponding spec; this ensures that
2634         --  a spec/body pair are always in the same SCC.
2635
2636         procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array);
2637         --  Set Nodes of the Root, and set SCC_Root of all the Nodes
2638
2639         procedure Init_SCC_Num_Pred (U : Unit_Id);
2640         --  Initialize the SCC_Num_Pred fields, so that the root of each SCC
2641         --  has a count of the number of successors of all the units in the
2642         --  SCC, but only for successors outside the SCC.
2643
2644         procedure Compute_SCCs is new Compute_Strongly_Connected_Components
2645           (Node       => Unit_Id,
2646            First_Node => Units.First,
2647            Last_Node  => Units.Last,
2648            Node_Array => Unit_Id_Array,
2649            Successors => Successors,
2650            Create_SCC => Create_SCC);
2651
2652         ----------------
2653         -- Create_SCC --
2654         ----------------
2655
2656         procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array) is
2657         begin
2658            if Debug_Flag_V then
2659               Write_Str ("Root = ");
2660               Write_Int (Int (Root));
2661               Write_Str (" ");
2662               Write_Unit_Name (Units.Table (Root).Uname);
2663               Write_Str (" -- ");
2664               Write_Int (Nodes'Length);
2665               Write_Line (" units:");
2666
2667               for J in Nodes'Range loop
2668                  Write_Str ("   ");
2669                  Write_Int (Int (Nodes (J)));
2670                  Write_Str (" ");
2671                  Write_Unit_Name (Units.Table (Nodes (J)).Uname);
2672                  Write_Eol;
2673               end loop;
2674            end if;
2675
2676            pragma Assert (Nodes (Nodes'First) = Root);
2677            pragma Assert (UNR.Table (Root).Nodes = null);
2678            UNR.Table (Root).Nodes := new Unit_Id_Array'(Nodes);
2679
2680            for J in Nodes'Range loop
2681               pragma Assert (SCC (Nodes (J)) = No_Unit_Id);
2682               UNR.Table (Nodes (J)).SCC_Root := Root;
2683            end loop;
2684         end Create_SCC;
2685
2686         ----------------
2687         -- Successors --
2688         ----------------
2689
2690         function Successors (U : Unit_Id) return Unit_Id_Array is
2691            S   : Successor_Id := UNR.Table (U).Successors;
2692            Tab : Unit_Id_Table;
2693
2694         begin
2695            --  Pretend that a spec is a successor of its body (even though it
2696            --  isn't), just so both get included.
2697
2698            if Units.Table (U).Utype = Is_Body then
2699               Append (Tab, Corresponding_Spec (U));
2700            end if;
2701
2702            --  Now include the real successors
2703
2704            while S /= No_Successor loop
2705               pragma Assert (Succ.Table (S).Before = U);
2706               Append (Tab, Succ.Table (S).After);
2707               S := Succ.Table (S).Next;
2708            end loop;
2709
2710            declare
2711               Result : constant Unit_Id_Array := Tab.Table (1 .. Last (Tab));
2712
2713            begin
2714               Free (Tab);
2715               return Result;
2716            end;
2717         end Successors;
2718
2719         -----------------------
2720         -- Init_SCC_Num_Pred --
2721         -----------------------
2722
2723         procedure Init_SCC_Num_Pred (U : Unit_Id) is
2724         begin
2725            if UNR.Table (U).Visited then
2726               return;
2727            end if;
2728
2729            UNR.Table (U).Visited := True;
2730
2731            declare
2732               S : Successor_Id := UNR.Table (U).Successors;
2733
2734            begin
2735               while S /= No_Successor loop
2736                  pragma Assert (Succ.Table (S).Before = U);
2737                  Init_SCC_Num_Pred (Succ.Table (S).After);
2738
2739                  if SCC (U) /= SCC (Succ.Table (S).After) then
2740                     UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred :=
2741                       UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred + 1;
2742                  end if;
2743
2744                  S := Succ.Table (S).Next;
2745               end loop;
2746            end;
2747         end Init_SCC_Num_Pred;
2748
2749      --  Start of processing for Compute_Unit_SCCs
2750
2751      begin
2752         Compute_SCCs;
2753
2754         for Uref in UNR.First .. UNR.Last loop
2755            pragma Assert (not UNR.Table (Uref).Visited);
2756            null;
2757         end loop;
2758
2759         for Uref in UNR.First .. UNR.Last loop
2760            Init_SCC_Num_Pred (Uref);
2761         end loop;
2762
2763         --  Assert that SCC_Root of all units has been set to a valid unit,
2764         --  and that SCC_Num_Pred has not been modified in non-root units.
2765
2766         for Uref in UNR.First .. UNR.Last loop
2767            pragma Assert (UNR.Table (Uref).SCC_Root /= No_Unit_Id);
2768            pragma Assert (UNR.Table (Uref).SCC_Root in UNR.First .. UNR.Last);
2769
2770            if SCC (Uref) /= Uref then
2771               pragma Assert (UNR.Table (Uref).SCC_Num_Pred = 0);
2772               null;
2773            end if;
2774         end loop;
2775      end Compute_Unit_SCCs;
2776
2777      --------------------------
2778      -- Find_Elab_All_Errors --
2779      --------------------------
2780
2781      procedure Find_Elab_All_Errors is
2782         Withed_Unit : Unit_Id;
2783
2784      begin
2785         for U in Units.First .. Units.Last loop
2786
2787            --  If this unit is not an interface to a stand-alone library,
2788            --  process WITH references for this unit ignoring interfaces to
2789            --  stand-alone libraries.
2790
2791            if not Units.Table (U).SAL_Interface then
2792               for W in Units.Table (U).First_With ..
2793                        Units.Table (U).Last_With
2794               loop
2795                  if Withs.Table (W).Sfile /= No_File
2796                    and then (not Withs.Table (W).SAL_Interface)
2797                  then
2798                     --  Check for special case of withing a unit that does not
2799                     --  exist any more.
2800
2801                     if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then
2802                        goto Next_With;
2803                     end if;
2804
2805                     Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname);
2806
2807                     --  If it's Elaborate_All or Elab_All_Desirable, check
2808                     --  that the withER and withEE are not in the same SCC.
2809
2810                     if Withs.Table (W).Elaborate_All
2811                       or else Withs.Table (W).Elab_All_Desirable
2812                     then
2813                        if SCC (U) = SCC (Withed_Unit) then
2814                           Elab_Cycle_Found := True; -- ???
2815
2816                           --  We could probably give better error messages
2817                           --  than Elab_Old here, but for now, to avoid
2818                           --  disruption, we don't give any error here.
2819                           --  Instead, we set the Elab_Cycle_Found flag above,
2820                           --  and then run the Elab_Old algorithm to issue the
2821                           --  error message. Ideally, we would like to print
2822                           --  multiple errors rather than stopping after the
2823                           --  first cycle.
2824
2825                           if False then
2826                              Error_Msg_Output
2827                                ("illegal pragma Elaborate_All",
2828                                 Info => False);
2829                           end if;
2830                        end if;
2831                     end if;
2832                  end if;
2833
2834                  <<Next_With>>
2835                  null;
2836               end loop;
2837            end if;
2838         end loop;
2839      end Find_Elab_All_Errors;
2840
2841      ---------------------
2842      -- Find_Elab_Order --
2843      ---------------------
2844
2845      procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
2846         Best_So_Far : Unit_Id;
2847         U           : Unit_Id;
2848
2849      begin
2850         --  Gather dependencies and output them if option set
2851
2852         Gather_Dependencies;
2853
2854         Compute_Unit_SCCs;
2855
2856         --  Initialize the no-predecessor list
2857
2858         No_Pred := No_Unit_Id;
2859         for U in UNR.First .. UNR.Last loop
2860            if UNR.Table (U).Num_Pred = 0 then
2861               UNR.Table (U).Nextnp := No_Pred;
2862               No_Pred := U;
2863            end if;
2864         end loop;
2865
2866         --  OK, now we determine the elaboration order proper. All we do is to
2867         --  select the best choice from the no-predecessor list until all the
2868         --  nodes have been chosen.
2869
2870         Outer : loop
2871            if Debug_Flag_N then
2872               Write_Line ("Outer loop");
2873            end if;
2874
2875            --  If there are no nodes with predecessors, then either we are
2876            --  done, as indicated by Num_Left being set to zero, or we have
2877            --  a circularity. In the latter case, diagnose the circularity,
2878            --  removing it from the graph and continue.
2879            --  ????But Diagnose_Elaboration_Problem always raises an
2880            --  exception, so the loop never goes around more than once.
2881
2882            Get_No_Pred : while No_Pred = No_Unit_Id loop
2883               exit Outer when Num_Left < 1;
2884               Diagnose_Elaboration_Problem (Elab_Order);
2885            end loop Get_No_Pred;
2886
2887            U := No_Pred;
2888            Best_So_Far := No_Unit_Id;
2889
2890            --  Loop to choose best entry in No_Pred list
2891
2892            No_Pred_Search : loop
2893               if Debug_Flag_N then
2894                  Write_Str ("  considering choice of ");
2895                  Write_Unit_Name (Units.Table (U).Uname);
2896                  Write_Eol;
2897
2898                  if Units.Table (U).Elaborate_Body then
2899                     Write_Str
2900                       ("    Elaborate_Body = True, Num_Pred for body = ");
2901                     Write_Int
2902                       (UNR.Table (Corresponding_Body (U)).Num_Pred);
2903                  else
2904                     Write_Str
2905                       ("    Elaborate_Body = False");
2906                  end if;
2907
2908                  Write_Eol;
2909               end if;
2910
2911               --  Don't even consider units whose SCC is not ready. This
2912               --  ensures that all units of an SCC will be elaborated
2913               --  together, with no other units in between.
2914
2915               if SCC_Num_Pred (U) = 0
2916                 and then Better_Choice (U, Best_So_Far)
2917               then
2918                  if Debug_Flag_N then
2919                     Write_Line ("    tentatively chosen (best so far)");
2920                  end if;
2921
2922                  Best_So_Far := U;
2923               else
2924                  if Debug_Flag_N then
2925                     Write_Line ("    SCC not ready");
2926                  end if;
2927               end if;
2928
2929               U := UNR.Table (U).Nextnp;
2930               exit No_Pred_Search when U = No_Unit_Id;
2931            end loop No_Pred_Search;
2932
2933            --  If there are no units on the No_Pred list whose SCC is ready,
2934            --  there must be a cycle. Defer to Elab_Old to print an error
2935            --  message.
2936
2937            if Best_So_Far = No_Unit_Id then
2938               Elab_Cycle_Found := True;
2939               return;
2940            end if;
2941
2942            --  Choose the best candidate found
2943
2944            Choose (Elab_Order, Best_So_Far, " [Best_So_Far]");
2945
2946            --  If it's a spec with a body, and the body is not yet chosen,
2947            --  choose the body if possible. The case where the body is
2948            --  already chosen is Elaborate_Body; the above call to Choose
2949            --  the spec will also Choose the body.
2950
2951            if Units.Table (Best_So_Far).Utype = Is_Spec
2952              and then UNR.Table
2953                         (Corresponding_Body (Best_So_Far)).Elab_Position = 0
2954            then
2955               declare
2956                  Choose_The_Body : constant Boolean :=
2957                                      UNR.Table (Corresponding_Body
2958                                        (Best_So_Far)).Num_Pred = 0;
2959
2960               begin
2961                  if Debug_Flag_B then
2962                     Write_Str ("Can we choose the body?... ");
2963
2964                     if Choose_The_Body then
2965                        Write_Line ("Yes!");
2966                     else
2967                        Write_Line ("No.");
2968                     end if;
2969                  end if;
2970
2971                  if Choose_The_Body then
2972                     Choose
2973                       (Elab_Order => Elab_Order,
2974                        Chosen     => Corresponding_Body (Best_So_Far),
2975                        Msg        => " [body]");
2976                  end if;
2977               end;
2978            end if;
2979
2980            --  Finally, choose all the rest of the units in the same SCC as
2981            --  Best_So_Far. If it hasn't been chosen (Elab_Position = 0), and
2982            --  it's ready to be chosen (Num_Pred = 0), then we can choose it.
2983
2984            loop
2985               declare
2986                  Chose_One_Or_More : Boolean := False;
2987                  SCC : Unit_Id_Array renames Nodes (Best_So_Far).all;
2988
2989               begin
2990                  for J in SCC'Range loop
2991                     if UNR.Table (SCC (J)).Elab_Position = 0
2992                       and then UNR.Table (SCC (J)).Num_Pred = 0
2993                     then
2994                        Chose_One_Or_More := True;
2995                        Choose (Elab_Order, SCC (J), " [same SCC]");
2996                     end if;
2997                  end loop;
2998
2999                  exit when not Chose_One_Or_More;
3000               end;
3001            end loop;
3002         end loop Outer;
3003
3004         Find_Elab_All_Errors;
3005      end Find_Elab_Order;
3006
3007      -----------
3008      -- Nodes --
3009      -----------
3010
3011      function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr is
3012      begin
3013         return UNR.Table (SCC (U)).Nodes;
3014      end Nodes;
3015
3016      ---------
3017      -- SCC --
3018      ---------
3019
3020      function SCC (U : Unit_Id) return Unit_Id is
3021      begin
3022         return UNR.Table (U).SCC_Root;
3023      end SCC;
3024
3025      ------------------
3026      -- SCC_Num_Pred --
3027      ------------------
3028
3029      function SCC_Num_Pred (U : Unit_Id) return Int is
3030      begin
3031         return UNR.Table (SCC (U)).SCC_Num_Pred;
3032      end SCC_Num_Pred;
3033
3034      ---------------
3035      -- Write_SCC --
3036      ---------------
3037
3038      procedure Write_SCC (U : Unit_Id) is
3039         pragma Assert (SCC (U) = U);
3040      begin
3041         for J in Nodes (U)'Range loop
3042            Write_Int (UNR.Table (Nodes (U) (J)).Elab_Position);
3043            Write_Str (". ");
3044            Write_Unit_Name (Units.Table (Nodes (U) (J)).Uname);
3045            Write_Eol;
3046         end loop;
3047
3048         Write_Eol;
3049      end Write_SCC;
3050
3051   end Elab_New;
3052
3053   --------------
3054   -- Elab_Old --
3055   --------------
3056
3057   package body Elab_Old is
3058
3059      ---------------------
3060      -- Find_Elab_Order --
3061      ---------------------
3062
3063      procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
3064         Best_So_Far : Unit_Id;
3065         U           : Unit_Id;
3066
3067      begin
3068         --  Gather dependencies and output them if option set
3069
3070         Gather_Dependencies;
3071
3072         --  Initialize the no-predecessor list
3073
3074         No_Pred := No_Unit_Id;
3075         for U in UNR.First .. UNR.Last loop
3076            if UNR.Table (U).Num_Pred = 0 then
3077               UNR.Table (U).Nextnp := No_Pred;
3078               No_Pred := U;
3079            end if;
3080         end loop;
3081
3082         --  OK, now we determine the elaboration order proper. All we do is to
3083         --  select the best choice from the no-predecessor list until all the
3084         --  nodes have been chosen.
3085
3086         Outer : loop
3087
3088            --  If there are no nodes with predecessors, then either we are
3089            --  done, as indicated by Num_Left being set to zero, or we have
3090            --  a circularity. In the latter case, diagnose the circularity,
3091            --  removing it from the graph and continue.
3092            --  ????But Diagnose_Elaboration_Problem always raises an
3093            --  exception, so the loop never goes around more than once.
3094
3095            Get_No_Pred : while No_Pred = No_Unit_Id loop
3096               exit Outer when Num_Left < 1;
3097               Diagnose_Elaboration_Problem (Elab_Order);
3098            end loop Get_No_Pred;
3099
3100            U := No_Pred;
3101            Best_So_Far := No_Unit_Id;
3102
3103            --  Loop to choose best entry in No_Pred list
3104
3105            No_Pred_Search : loop
3106               if Debug_Flag_N then
3107                  Write_Str ("  considering choice of ");
3108                  Write_Unit_Name (Units.Table (U).Uname);
3109                  Write_Eol;
3110
3111                  if Units.Table (U).Elaborate_Body then
3112                     Write_Str
3113                       ("    Elaborate_Body = True, Num_Pred for body = ");
3114                     Write_Int
3115                       (UNR.Table (Corresponding_Body (U)).Num_Pred);
3116                  else
3117                     Write_Str
3118                       ("    Elaborate_Body = False");
3119                  end if;
3120
3121                  Write_Eol;
3122               end if;
3123
3124               --  This is a candididate to be considered for choice
3125
3126               if Better_Choice (U, Best_So_Far) then
3127                  if Debug_Flag_N then
3128                     Write_Line ("    tentatively chosen (best so far)");
3129                  end if;
3130
3131                  Best_So_Far := U;
3132               end if;
3133
3134               U := UNR.Table (U).Nextnp;
3135               exit No_Pred_Search when U = No_Unit_Id;
3136            end loop No_Pred_Search;
3137
3138            --  Choose the best candidate found
3139
3140            Choose (Elab_Order, Best_So_Far, " [Elab_Old Best_So_Far]");
3141         end loop Outer;
3142      end Find_Elab_Order;
3143
3144   end Elab_Old;
3145
3146end Binde;
3147