gcc/ada/binde.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                B I N D E                                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2007, 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 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Binderr;  use Binderr;
  28 with Butil;    use Butil;
  29 with Debug;    use Debug;
  30 with Fname;    use Fname;
  31 with Lib;      use Lib;
  32 with Namet;    use Namet;
  33 with Opt;      use Opt;
  34 with Output;   use Output;
  35 with Targparm; use Targparm;
  36
  37 package body Binde is
  38
  39    --  The following data structures are used to represent the graph that is
  40    --  used to determine the elaboration order (using a topological sort).
  41
  42    --  The following structures are used to record successors. If A is a
  43    --  successor of B in this table, it means that A must be elaborated
  44    --  before B is elaborated.
  45
  46    type Successor_Id is new Nat;
  47    --  Identification of single successor entry
  48
  49    No_Successor : constant Successor_Id := 0;
  50    --  Used to indicate end of list of successors
  51
  52    type Elab_All_Id is new Nat;
  53    --  Identification of Elab_All entry link
  54
  55    No_Elab_All_Link : constant Elab_All_Id := 0;
  56    --  Used to indicate end of list
  57
  58    --  Succ_Reason indicates the reason for a particular elaboration link
  59
  60    type Succ_Reason is
  61      (Withed,
  62       --  After directly with's Before, so the spec of Before must be
  63       --  elaborated before After is elaborated.
  64
  65       Elab,
  66       --  After directly mentions Before in a pragma Elaborate, so the
  67       --  body of Before must be elaborate before After is elaborated.
  68
  69       Elab_All,
  70       --  After either mentions Before directly in a pragma Elaborate_All,
  71       --  or mentions a third unit, X, which itself requires that Before be
  72       --  elaborated before unit X is elaborated. The Elab_All_Link list
  73       --  traces the dependencies in the latter case.
  74
  75       Elab_All_Desirable,
  76       --  This is just like Elab_All, except that the elaborate all was not
  77       --  explicitly present in the source, but rather was created by the
  78       --  front end, which decided that it was "desirable".
  79
  80       Elab_Desirable,
  81       --  This is just like Elab, except that the elaborate was not
  82       --  explicitly present in the source, but rather was created by the
  83       --  front end, which decided that it was "desirable".
  84
  85       Spec_First);
  86       --  After is a body, and Before is the corresponding spec
  87
  88    --  Successor_Link contains the information for one link
  89
  90    type Successor_Link is record
  91       Before : Unit_Id;
  92       --  Predecessor unit
  93
  94       After : Unit_Id;
  95       --  Successor unit
  96
  97       Next : Successor_Id;
  98       --  Next successor on this list
  99
 100       Reason : Succ_Reason;
 101       --  Reason for this link
 102
 103       Elab_Body : Boolean;
 104       --  Set True if this link is needed for the special Elaborate_Body
 105       --  processing described below.
 106
 107       Reason_Unit : Unit_Id;
 108       --  For Reason = Elab, or Elab_All or Elab_Desirable, records the unit
 109       --  containing the pragma leading to the link.
 110
 111       Elab_All_Link : Elab_All_Id;
 112       --  If Reason = Elab_All or Elab_Desirable, then this points to the
 113       --  first elment in a list of Elab_All entries that record the with
 114       --  chain leading resulting in this particular dependency.
 115
 116    end record;
 117
 118    --  Note on handling of Elaborate_Body. Basically, if we have a pragma
 119    --  Elaborate_Body in a unit, it means that the spec and body have to
 120    --  be handled as a single entity from the point of view of determining
 121    --  an elaboration order. What we do is to essentially remove the body
 122    --  from consideration completely, and transfer all its links (other
 123    --  than the spec link) to the spec. Then when then the spec gets chosen,
 124    --  we choose the body right afterwards. We mark the links that get moved
 125    --  from the body to the spec by setting their Elab_Body flag True, so
 126    --  that we can understand what is going on!
 127
 128    Succ_First : constant := 1;
 129
 130    package Succ is new Table.Table (
 131      Table_Component_Type => Successor_Link,
 132      Table_Index_Type     => Successor_Id,
 133      Table_Low_Bound      => Succ_First,
 134      Table_Initial        => 500,
 135      Table_Increment      => 200,
 136      Table_Name           => "Succ");
 137
 138    --  For the case of Elaborate_All, the following table is used to record
 139    --  chains of with relationships that lead to the Elab_All link. These
 140    --  are used solely for diagnostic purposes
 141
 142    type Elab_All_Entry is record
 143       Needed_By : Unit_Name_Type;
 144       --  Name of unit from which referencing unit was with'ed or otherwise
 145       --  needed as a result of Elaborate_All or Elaborate_Desirable.
 146
 147       Next_Elab : Elab_All_Id;
 148       --  Link to next entry on chain (No_Elab_All_Link marks end of list)
 149    end record;
 150
 151    package Elab_All_Entries is new Table.Table (
 152      Table_Component_Type => Elab_All_Entry,
 153      Table_Index_Type     => Elab_All_Id,
 154      Table_Low_Bound      => 1,
 155      Table_Initial        => 2000,
 156      Table_Increment      => 200,
 157      Table_Name           => "Elab_All_Entries");
 158
 159    --  A Unit_Node record is built for each active unit
 160
 161    type Unit_Node_Record is record
 162
 163       Successors : Successor_Id;
 164       --  Pointer to list of links for successor nodes
 165
 166       Num_Pred : Int;
 167       --  Number of predecessors for this unit. Normally non-negative, but
 168       --  can go negative in the case of units chosen by the diagnose error
 169       --  procedure (when cycles are being removed from the graph).
 170
 171       Nextnp : Unit_Id;
 172       --  Forward pointer for list of units with no predecessors
 173
 174       Elab_Order : Nat;
 175       --  Position in elaboration order (zero = not placed yet)
 176
 177       Visited : Boolean;
 178       --  Used in computing transitive closure for elaborate all and
 179       --  also in locating cycles and paths in the diagnose routines.
 180
 181       Elab_Position : Natural;
 182       --  Initialized to zero. Set non-zero when a unit is chosen and
 183       --  placed in the elaboration order. The value represents the
 184       --  ordinal position in the elaboration order.
 185
 186    end record;
 187
 188    package UNR is new Table.Table (
 189      Table_Component_Type => Unit_Node_Record,
 190      Table_Index_Type     => Unit_Id,
 191      Table_Low_Bound      => First_Unit_Entry,
 192      Table_Initial        => 500,
 193      Table_Increment      => 200,
 194      Table_Name           => "UNR");
 195
 196    No_Pred : Unit_Id;
 197    --  Head of list of items with no predecessors
 198
 199    Num_Left : Int;
 200    --  Number of entries not yet dealt with
 201
 202    Cur_Unit : Unit_Id;
 203    --  Current unit, set by Gather_Dependencies, and picked up in Build_Link
 204    --  to set the Reason_Unit field of the created dependency link.
 205
 206    Num_Chosen : Natural := 0;
 207    --  Number of units chosen in the elaboration order so far
 208
 209    -----------------------
 210    -- Local Subprograms --
 211    -----------------------
 212
 213    function Better_Choice (U1, U2 : Unit_Id) return Boolean;
 214    --  U1 and U2 are both permitted candidates for selection as the next unit
 215    --  to be elaborated. This function determines whether U1 is a better choice
 216    --  than U2, i.e. should be elaborated in preference to U2, based on a set
 217    --  of heuristics that establish a friendly and predictable order (see body
 218    --  for details). The result is True if U1 is a better choice than U2, and
 219    --  False if it is a worse choice, or there is no preference between them.
 220
 221    procedure Build_Link
 222      (Before : Unit_Id;
 223       After  : Unit_Id;
 224       R      : Succ_Reason;
 225       Ea_Id  : Elab_All_Id := No_Elab_All_Link);
 226    --  Establish a successor link, Before must be elaborated before After,
 227    --  and the reason for the link is R. Ea_Id is the contents to be placed
 228    --  in the Elab_All_Link of the entry.
 229
 230    procedure Choose (Chosen : Unit_Id);
 231    --  Chosen is the next entry chosen in the elaboration order. This
 232    --  procedure updates all data structures appropriately.
 233
 234    function Corresponding_Body (U : Unit_Id) return Unit_Id;
 235    pragma Inline (Corresponding_Body);
 236    --  Given a unit which is a spec for which there is a separate body,
 237    --  return the unit id of the body. It is an error to call this routine
 238    --  with a unit that is not a spec, or which does not have a separate body.
 239
 240    function Corresponding_Spec (U : Unit_Id) return Unit_Id;
 241    pragma Inline (Corresponding_Spec);
 242    --  Given a unit which is a body for which there is a separate spec,
 243    --  return the unit id of the spec. It is an error to call this routine
 244    --  with a unit that is not a body, or which does not have a separate spec.
 245
 246    procedure Diagnose_Elaboration_Problem;
 247    --  Called when no elaboration order can be found. Outputs an appropriate
 248    --  diagnosis of the problem, and then abandons the bind.
 249
 250    procedure Elab_All_Links
 251      (Before : Unit_Id;
 252       After  : Unit_Id;
 253       Reason : Succ_Reason;
 254       Link   : Elab_All_Id);
 255    --  Used to compute the transitive closure of elaboration links for an
 256    --  Elaborate_All pragma (Reason = Elab_All) or for an indication of
 257    --  Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has
 258    --  a pragma Elaborate_All or the front end has determined that a reference
 259    --  probably requires Elaborate_All is required, and unit Before must be
 260    --  previously elaborated. First a link is built making sure that unit
 261    --  Before is elaborated before After, then a recursive call ensures that
 262    --  we also build links for any units needed by Before (i.e. these units
 263    --  must/should also be elaborated before After). Link is used to build
 264    --  a chain of Elab_All_Entries to explain the reason for a link. The
 265    --  value passed is the chain so far.
 266
 267    procedure Elab_Error_Msg (S : Successor_Id);
 268    --  Given a successor link, outputs an error message of the form
 269    --  "$ must be elaborated before $ ..." where ... is the reason.
 270
 271    procedure Gather_Dependencies;
 272    --  Compute dependencies, building the Succ and UNR tables
 273
 274    function Is_Body_Unit (U : Unit_Id) return Boolean;
 275    pragma Inline (Is_Body_Unit);
 276    --  Determines if given unit is a body
 277
 278    function Is_Waiting_Body (U : Unit_Id) return Boolean;
 279    pragma Inline (Is_Waiting_Body);
 280    --  Determines if U is a waiting body, defined as a body which has
 281    --  not been elaborated, but whose spec has been elaborated.
 282
 283    function Make_Elab_Entry
 284      (Unam : Unit_Name_Type;
 285       Link : Elab_All_Id) return Elab_All_Id;
 286    --  Make an Elab_All_Entries table entry with the given Unam and Link
 287
 288    function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id;
 289    --  This function uses the Info field set in the names table to obtain
 290    --  the unit Id of a unit, given its name id value.
 291
 292    function Worse_Choice (U1, U2 : Unit_Id) return Boolean;
 293    --  This is like Better_Choice, and has the same interface, but returns
 294    --  true if U1 is a worse choice than U2 in the sense of the -h (horrible
 295    --  elaboration order) switch. We still have to obey Ada rules, so it is
 296    --  not quite the direct inverse of Better_Choice.
 297
 298    procedure Write_Dependencies;
 299    --  Write out dependencies (called only if appropriate option is set)
 300
 301    procedure Write_Elab_All_Chain (S : Successor_Id);
 302    --  If the reason for the link S is Elaborate_All or Elaborate_Desirable,
 303    --  then this routine will output the "needed by" explanation chain.
 304
 305    -------------------
 306    -- Better_Choice --
 307    -------------------
 308
 309    function Better_Choice (U1, U2 : Unit_Id) return Boolean is
 310       UT1 : Unit_Record renames Units.Table (U1);
 311       UT2 : Unit_Record renames Units.Table (U2);
 312
 313    begin
 314       if Debug_Flag_B then
 315          Write_Str ("Better_Choice (");
 316          Write_Unit_Name (UT1.Uname);
 317          Write_Str (", ");
 318          Write_Unit_Name (UT2.Uname);
 319          Write_Line (")");
 320       end if;
 321
 322       --  Note: the checks here are applied in sequence, and the ordering is
 323       --  significant (i.e. the more important criteria are applied first).
 324
 325       --  Prefer a waiting body to any other case
 326
 327       if Is_Waiting_Body (U1) and not Is_Waiting_Body (U2) then
 328          if Debug_Flag_B then
 329             Write_Line ("  True: u1 is waiting body, u2 is not");
 330          end if;
 331
 332          return True;
 333
 334       elsif Is_Waiting_Body (U2) and not Is_Waiting_Body (U1) then
 335          if Debug_Flag_B then
 336             Write_Line ("  False: u2 is waiting body, u1 is not");
 337          end if;
 338
 339          return False;
 340
 341       --  Prefer a predefined unit to a non-predefined unit
 342
 343       elsif UT1.Predefined and not UT2.Predefined then
 344          if Debug_Flag_B then
 345             Write_Line ("  True: u1 is predefined, u2 is not");
 346          end if;
 347
 348          return True;
 349
 350       elsif UT2.Predefined and not UT1.Predefined then
 351          if Debug_Flag_B then
 352             Write_Line ("  False: u2 is predefined, u1 is not");
 353          end if;
 354
 355          return False;
 356
 357       --  Prefer an internal unit to a non-internal unit
 358
 359       elsif UT1.Internal and not UT2.Internal then
 360          if Debug_Flag_B then
 361             Write_Line ("  True: u1 is internal, u2 is not");
 362          end if;
 363          return True;
 364
 365       elsif UT2.Internal and not UT1.Internal then
 366          if Debug_Flag_B then
 367             Write_Line ("  False: u2 is internal, u1 is not");
 368          end if;
 369
 370          return False;
 371
 372       --  Prefer a body to a spec
 373
 374       elsif Is_Body_Unit (U1) and not Is_Body_Unit (U2) then
 375          if Debug_Flag_B then
 376             Write_Line ("  True: u1 is body, u2 is not");
 377          end if;
 378
 379          return True;
 380
 381       elsif Is_Body_Unit (U2) and not Is_Body_Unit (U1) then
 382          if Debug_Flag_B then
 383             Write_Line ("  False: u2 is body, u1 is not");
 384          end if;
 385
 386          return False;
 387
 388       --  If both are waiting bodies, then prefer the one whose spec is
 389       --  more recently elaborated. Consider the following:
 390
 391       --     spec of A
 392       --     spec of B
 393       --     body of A or B?
 394
 395       --  The normal waiting body preference would have placed the body of
 396       --  A before the spec of B if it could. Since it could not, there it
 397       --  must be the case that A depends on B. It is therefore a good idea
 398       --  to put the body of B first.
 399
 400       elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
 401          declare
 402             Result : constant Boolean :=
 403                        UNR.Table (Corresponding_Spec (U1)).Elab_Position >
 404                        UNR.Table (Corresponding_Spec (U2)).Elab_Position;
 405          begin
 406             if Debug_Flag_B then
 407                if Result then
 408                   Write_Line ("  True: based on waiting body elab positions");
 409                else
 410                   Write_Line ("  False: based on waiting body elab positions");
 411                end if;
 412             end if;
 413
 414             return Result;
 415          end;
 416       end if;
 417
 418       --  Remaining choice rules are disabled by Debug flag -do
 419
 420       if not Debug_Flag_O then
 421
 422          --  The following deal with the case of specs which have been marked
 423          --  as Elaborate_Body_Desirable. We generally want to delay these
 424          --  specs as long as possible, so that the bodies have a better chance
 425          --  of being elaborated closer to the specs.
 426
 427          --  If we have two units, one of which is a spec for which this flag
 428          --  is set, and the other is not, we prefer to delay the spec for
 429          --  which the flag is set.
 430
 431          if not UT1.Elaborate_Body_Desirable
 432            and then UT2.Elaborate_Body_Desirable
 433          then
 434             if Debug_Flag_B then
 435                Write_Line ("  True: u1 is elab body desirable, u2 is not");
 436             end if;
 437
 438             return True;
 439
 440          elsif not UT2.Elaborate_Body_Desirable
 441            and then UT1.Elaborate_Body_Desirable
 442          then
 443             if Debug_Flag_B then
 444                Write_Line ("  False: u1 is elab body desirable, u2 is not");
 445             end if;
 446
 447             return False;
 448
 449             --  If we have two specs that are both marked as Elaborate_Body
 450             --  desirable, we prefer the one whose body is nearer to being able
 451             --  to be elaborated, based on the Num_Pred count. This helps to
 452             --  ensure bodies are as close to specs as possible.
 453
 454          elsif UT1.Elaborate_Body_Desirable
 455            and then UT2.Elaborate_Body_Desirable
 456          then
 457             declare
 458                Result : constant Boolean :=
 459                           UNR.Table (Corresponding_Body (U1)).Num_Pred <
 460                           UNR.Table (Corresponding_Body (U2)).Num_Pred;
 461             begin
 462                if Debug_Flag_B then
 463                   if Result then
 464                      Write_Line ("  True based on Num_Pred compare");
 465                   else
 466                      Write_Line ("  False based on Num_Pred compare");
 467                   end if;
 468                end if;
 469
 470                return Result;
 471             end;
 472          end if;
 473       end if;
 474
 475       --  If we fall through, it means that no preference rule applies, so we
 476       --  use alphabetical order to at least give a deterministic result.
 477
 478       if Debug_Flag_B then
 479          Write_Line ("  choose on alpha order");
 480       end if;
 481
 482       return Uname_Less (UT1.Uname, UT2.Uname);
 483    end Better_Choice;
 484
 485    ----------------
 486    -- Build_Link --
 487    ----------------
 488
 489    procedure Build_Link
 490      (Before : Unit_Id;
 491       After  : Unit_Id;
 492       R      : Succ_Reason;
 493       Ea_Id  : Elab_All_Id := No_Elab_All_Link)
 494    is
 495       Cspec : Unit_Id;
 496
 497    begin
 498       Succ.Increment_Last;
 499       Succ.Table (Succ.Last).Before          := Before;
 500       Succ.Table (Succ.Last).Next            := UNR.Table (Before).Successors;
 501       UNR.Table (Before).Successors          := Succ.Last;
 502       Succ.Table (Succ.Last).Reason          := R;
 503       Succ.Table (Succ.Last).Reason_Unit     := Cur_Unit;
 504       Succ.Table (Succ.Last).Elab_All_Link   := Ea_Id;
 505
 506       --  Deal with special Elab_Body case. If the After of this link is
 507       --  a body whose spec has Elaborate_All set, and this is not the link
 508       --  directly from the body to the spec, then we make the After of the
 509       --  link reference its spec instead, marking the link appropriately.
 510
 511       if Units.Table (After).Utype = Is_Body then
 512          Cspec := Corresponding_Spec (After);
 513
 514          if Units.Table (Cspec).Elaborate_Body
 515            and then Cspec /= Before
 516          then
 517             Succ.Table (Succ.Last).After     := Cspec;
 518             Succ.Table (Succ.Last).Elab_Body := True;
 519             UNR.Table (Cspec).Num_Pred       := UNR.Table (Cspec).Num_Pred + 1;
 520             return;
 521          end if;
 522       end if;
 523
 524       --  Fall through on normal case
 525
 526       Succ.Table (Succ.Last).After           := After;
 527       Succ.Table (Succ.Last).Elab_Body       := False;
 528       UNR.Table (After).Num_Pred             := UNR.Table (After).Num_Pred + 1;
 529    end Build_Link;
 530
 531    ------------
 532    -- Choose --
 533    ------------
 534
 535    procedure Choose (Chosen : Unit_Id) is
 536       S : Successor_Id;
 537       U : Unit_Id;
 538
 539    begin
 540       if Debug_Flag_C then
 541          Write_Str ("Choosing Unit ");
 542          Write_Unit_Name (Units.Table (Chosen).Uname);
 543          Write_Eol;
 544       end if;
 545
 546       --  Add to elaboration order. Note that units having no elaboration
 547       --  code are not treated specially yet. The special casing of this
 548       --  is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile
 549       --  we need them here, because the object file list is also driven
 550       --  by the contents of the Elab_Order table.
 551
 552       Elab_Order.Increment_Last;
 553       Elab_Order.Table (Elab_Order.Last) := Chosen;
 554
 555       --  Remove from No_Pred list. This is a little inefficient and may
 556       --  be we should doubly link the list, but it will do for now!
 557
 558       if No_Pred = Chosen then
 559          No_Pred := UNR.Table (Chosen).Nextnp;
 560
 561       else
 562          --  Note that we just ignore the situation where it does not
 563          --  appear in the No_Pred list, this happens in calls from the
 564          --  Diagnose_Elaboration_Problem routine, where cycles are being
 565          --  removed arbitrarily from the graph.
 566
 567          U := No_Pred;
 568          while U /= No_Unit_Id loop
 569             if UNR.Table (U).Nextnp = Chosen then
 570                UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp;
 571                exit;
 572             end if;
 573
 574             U := UNR.Table (U).Nextnp;
 575          end loop;
 576       end if;
 577
 578       --  For all successors, decrement the number of predecessors, and
 579       --  if it becomes zero, then add to no predecessor list.
 580
 581       S := UNR.Table (Chosen).Successors;
 582       while S /= No_Successor loop
 583          U := Succ.Table (S).After;
 584          UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1;
 585
 586          if Debug_Flag_N then
 587             Write_Str ("  decrementing Num_Pred for unit ");
 588             Write_Unit_Name (Units.Table (U).Uname);
 589             Write_Str (" new value = ");
 590             Write_Int (Int (UNR.Table (U).Num_Pred));
 591             Write_Eol;
 592          end if;
 593
 594          if UNR.Table (U).Num_Pred = 0 then
 595             UNR.Table (U).Nextnp := No_Pred;
 596             No_Pred := U;
 597          end if;
 598
 599          S := Succ.Table (S).Next;
 600       end loop;
 601
 602       --  All done, adjust number of units left count and set elaboration pos
 603
 604       Num_Left := Num_Left - 1;
 605       Num_Chosen := Num_Chosen + 1;
 606       UNR.Table (Chosen).Elab_Position := Num_Chosen;
 607       Units.Table (Chosen).Elab_Position := Num_Chosen;
 608
 609       --  If we just chose a spec with Elaborate_Body set, then we
 610       --  must immediately elaborate the body, before any other units.
 611
 612       if Units.Table (Chosen).Elaborate_Body then
 613
 614          --  If the unit is a spec only, then there is no body. This is a bit
 615          --  odd given that Elaborate_Body is here, but it is valid in an
 616          --  RCI unit, where we only have the interface in the stub bind.
 617
 618          if Units.Table (Chosen).Utype = Is_Spec_Only
 619            and then Units.Table (Chosen).RCI
 620          then
 621             null;
 622          else
 623             Choose (Corresponding_Body (Chosen));
 624          end if;
 625       end if;
 626    end Choose;
 627
 628    ------------------------
 629    -- Corresponding_Body --
 630    ------------------------
 631
 632    --  Currently if the body and spec are separate, then they appear as
 633    --  two separate units in the same ALI file, with the body appearing
 634    --  first and the spec appearing second.
 635
 636    function Corresponding_Body (U : Unit_Id) return Unit_Id is
 637    begin
 638       pragma Assert (Units.Table (U).Utype = Is_Spec);
 639       return U - 1;
 640    end Corresponding_Body;
 641
 642    ------------------------
 643    -- Corresponding_Spec --
 644    ------------------------
 645
 646    --  Currently if the body and spec are separate, then they appear as
 647    --  two separate units in the same ALI file, with the body appearing
 648    --  first and the spec appearing second.
 649
 650    function Corresponding_Spec (U : Unit_Id) return Unit_Id is
 651    begin
 652       pragma Assert (Units.Table (U).Utype = Is_Body);
 653       return U + 1;
 654    end Corresponding_Spec;
 655
 656    ----------------------------------
 657    -- Diagnose_Elaboration_Problem --
 658    ----------------------------------
 659
 660    procedure Diagnose_Elaboration_Problem is
 661
 662       function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean;
 663       --  Recursive routine used to find a path from node Ufrom to node Uto.
 664       --  If a path exists, returns True and outputs an appropriate set of
 665       --  error messages giving the path. Also calls Choose for each of the
 666       --  nodes so that they get removed from the remaining set. There are
 667       --  two cases of calls, either Ufrom = Uto for an attempt to find a
 668       --  cycle, or Ufrom is a spec and Uto the corresponding body for the
 669       --  case of an unsatisfiable Elaborate_Body pragma. ML is the minimum
 670       --  acceptable length for a path.
 671
 672       ---------------
 673       -- Find_Path --
 674       ---------------
 675
 676       function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is
 677
 678          function Find_Link (U : Unit_Id; PL : Nat) return Boolean;
 679          --  This is the inner recursive routine, it determines if a path
 680          --  exists from U to Uto, and if so returns True and outputs the
 681          --  appropriate set of error messages. PL is the path length
 682
 683          ---------------
 684          -- Find_Link --
 685          ---------------
 686
 687          function Find_Link (U : Unit_Id; PL : Nat) return Boolean is
 688             S : Successor_Id;
 689
 690          begin
 691             --  Recursion ends if we are at terminating node and the path
 692             --  is sufficiently long, generate error message and return True.
 693
 694             if U = Uto and then PL >= ML then
 695                Choose (U);
 696                return True;
 697
 698             --  All done if already visited, otherwise mark as visited
 699
 700             elsif UNR.Table (U).Visited then
 701                return False;
 702
 703             --  Otherwise mark as visited and look at all successors
 704
 705             else
 706                UNR.Table (U).Visited := True;
 707
 708                S := UNR.Table (U).Successors;
 709                while S /= No_Successor loop
 710                   if Find_Link (Succ.Table (S).After, PL + 1) then
 711                      Elab_Error_Msg (S);
 712                      Choose (U);
 713                      return True;
 714                   end if;
 715
 716                   S := Succ.Table (S).Next;
 717                end loop;
 718
 719                --  Falling through means this does not lead to a path
 720
 721                return False;
 722             end if;
 723          end Find_Link;
 724
 725       --  Start of processing for Find_Path
 726
 727       begin
 728          --  Initialize all non-chosen nodes to not visisted yet
 729
 730          for U in Units.First .. Units.Last loop
 731             UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0;
 732          end loop;
 733
 734          --  Now try to find the path
 735
 736          return Find_Link (Ufrom, 0);
 737       end Find_Path;
 738
 739    --  Start of processing for Diagnose_Elaboration_Error
 740
 741    begin
 742       Set_Standard_Error;
 743
 744       --  Output state of things if debug flag N set
 745
 746       if Debug_Flag_N then
 747          declare
 748             NP : Int;
 749
 750          begin
 751             Write_Eol;
 752             Write_Eol;
 753             Write_Str ("Diagnose_Elaboration_Problem called");
 754             Write_Eol;
 755             Write_Str ("List of remaining unchosen units and predecessors");
 756             Write_Eol;
 757
 758             for U in Units.First .. Units.Last loop
 759                if UNR.Table (U).Elab_Position = 0 then
 760                   NP := UNR.Table (U).Num_Pred;
 761                   Write_Eol;
 762                   Write_Str ("  Unchosen unit: #");
 763                   Write_Int (Int (U));
 764                   Write_Str ("  ");
 765                   Write_Unit_Name (Units.Table (U).Uname);
 766                   Write_Str (" (Num_Pred = ");
 767                   Write_Int (NP);
 768                   Write_Char (')');
 769                   Write_Eol;
 770
 771                   if NP = 0 then
 772                      if Units.Table (U).Elaborate_Body then
 773                         Write_Str
 774                           ("    (not chosen because of Elaborate_Body)");
 775                         Write_Eol;
 776                      else
 777                         Write_Str ("  ****************** why not chosen?");
 778                         Write_Eol;
 779                      end if;
 780                   end if;
 781
 782                   --  Search links list to find unchosen predecessors
 783
 784                   for S in Succ.First .. Succ.Last loop
 785                      declare
 786                         SL : Successor_Link renames Succ.Table (S);
 787
 788                      begin
 789                         if SL.After = U
 790                           and then UNR.Table (SL.Before).Elab_Position = 0
 791                         then
 792                            Write_Str ("    unchosen predecessor: #");
 793                            Write_Int (Int (SL.Before));
 794                            Write_Str ("  ");
 795                            Write_Unit_Name (Units.Table (SL.Before).Uname);
 796                            Write_Eol;
 797                            NP := NP - 1;
 798                         end if;
 799                      end;
 800                   end loop;
 801
 802                   if NP /= 0 then
 803                      Write_Str ("  **************** Num_Pred value wrong!");
 804                      Write_Eol;
 805                   end if;
 806                end if;
 807             end loop;
 808          end;
 809       end if;
 810
 811       --  Output the header for the error, and manually increment the
 812       --  error count. We are using Error_Msg_Output rather than Error_Msg
 813       --  here for two reasons:
 814
 815       --    This is really only one error, not one for each line
 816       --    We want this output on standard output since it is voluminous
 817
 818       --  But we do need to deal with the error count manually in this case
 819
 820       Errors_Detected := Errors_Detected + 1;
 821       Error_Msg_Output ("elaboration circularity detected", Info => False);
 822
 823       --  Try to find cycles starting with any of the remaining nodes that have
 824       --  not yet been chosen. There must be at least one (there is some reason
 825       --  we are being called!)
 826
 827       for U in Units.First .. Units.Last loop
 828          if UNR.Table (U).Elab_Position = 0 then
 829             if Find_Path (U, U, 1) then
 830                raise Unrecoverable_Error;
 831             end if;
 832          end if;
 833       end loop;
 834
 835       --  We should never get here, since we were called for some reason,
 836       --  and we should have found and eliminated at least one bad path.
 837
 838       raise Program_Error;
 839    end Diagnose_Elaboration_Problem;
 840
 841    --------------------
 842    -- Elab_All_Links --
 843    --------------------
 844
 845    procedure Elab_All_Links
 846      (Before : Unit_Id;
 847       After  : Unit_Id;
 848       Reason : Succ_Reason;
 849       Link   : Elab_All_Id)
 850    is
 851    begin
 852       if UNR.Table (Before).Visited then
 853          return;
 854       end if;
 855
 856       --  Build the direct link for Before
 857
 858       UNR.Table (Before).Visited := True;
 859       Build_Link (Before, After, Reason, Link);
 860
 861       --  Process all units with'ed by Before recursively
 862
 863       for W in
 864         Units.Table (Before).First_With .. Units.Table (Before).Last_With
 865       loop
 866          --  Skip if this with is an interface to a stand-alone library.
 867          --  Skip also if no ALI file for this with, happens with certain
 868          --  specialized generic files that do not get compiled.
 869
 870          if not Withs.Table (W).SAL_Interface
 871            and then Withs.Table (W).Afile /= No_File
 872            and then Generic_Separately_Compiled (Withs.Table (W).Sfile)
 873          then
 874             Elab_All_Links
 875               (Unit_Id_Of (Withs.Table (W).Uname),
 876                After,
 877                Reason,
 878                Make_Elab_Entry (Withs.Table (W).Uname, Link));
 879          end if;
 880       end loop;
 881
 882       --  Process corresponding body, if there is one
 883
 884       if Units.Table (Before).Utype = Is_Spec then
 885          Elab_All_Links
 886            (Corresponding_Body (Before),
 887             After, Reason,
 888             Make_Elab_Entry
 889               (Units.Table (Corresponding_Body (Before)).Uname, Link));
 890       end if;
 891    end Elab_All_Links;
 892
 893    --------------------
 894    -- Elab_Error_Msg --
 895    --------------------
 896
 897    procedure Elab_Error_Msg (S : Successor_Id) is
 898       SL : Successor_Link renames Succ.Table (S);
 899
 900    begin
 901       --  Nothing to do if internal unit involved and no -da flag
 902
 903       if not Debug_Flag_A
 904         and then
 905           (Is_Internal_File_Name (Units.Table (SL.Before).Sfile)
 906             or else
 907            Is_Internal_File_Name (Units.Table (SL.After).Sfile))
 908       then
 909          return;
 910       end if;
 911
 912       --  Here we want to generate output
 913
 914       Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
 915
 916       if SL.Elab_Body then
 917          Error_Msg_Unit_2 := Units.Table (Corresponding_Body (SL.After)).Uname;
 918       else
 919          Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
 920       end if;
 921
 922       Error_Msg_Output ("  $ must be elaborated before $", Info => True);
 923
 924       Error_Msg_Unit_1 := Units.Table (SL.Reason_Unit).Uname;
 925
 926       case SL.Reason is
 927          when Withed =>
 928             Error_Msg_Output
 929               ("     reason: with clause",
 930                Info => True);
 931
 932          when Elab =>
 933             Error_Msg_Output
 934               ("     reason: pragma Elaborate in unit $",
 935                Info => True);
 936
 937          when Elab_All =>
 938             Error_Msg_Output
 939               ("     reason: pragma Elaborate_All in unit $",
 940                Info => True);
 941
 942          when Elab_All_Desirable =>
 943             Error_Msg_Output
 944               ("     reason: implicit Elaborate_All in unit $",
 945                Info => True);
 946
 947             Error_Msg_Output
 948               ("     recompile $ with -gnatwl for full details",
 949                Info => True);
 950
 951          when Elab_Desirable =>
 952             Error_Msg_Output
 953               ("     reason: implicit Elaborate in unit $",
 954                Info => True);
 955
 956             Error_Msg_Output
 957               ("     recompile $ with -gnatwl for full details",
 958                Info => True);
 959
 960          when Spec_First =>
 961             Error_Msg_Output
 962               ("     reason: spec always elaborated before body",
 963                Info => True);
 964       end case;
 965
 966       Write_Elab_All_Chain (S);
 967
 968       if SL.Elab_Body then
 969          Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
 970          Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
 971          Error_Msg_Output
 972            ("  $ must therefore be elaborated before $",
 973             True);
 974
 975          Error_Msg_Unit_1 := Units.Table (SL.After).Uname;
 976          Error_Msg_Output
 977            ("     (because $ has a pragma Elaborate_Body)",
 978             True);
 979       end if;
 980
 981       if not Zero_Formatting then
 982          Write_Eol;
 983       end if;
 984    end Elab_Error_Msg;
 985
 986    ---------------------
 987    -- Find_Elab_Order --
 988    ---------------------
 989
 990    procedure Find_Elab_Order is
 991       U           : Unit_Id;
 992       Best_So_Far : Unit_Id;
 993
 994    begin
 995       Succ.Init;
 996       Num_Left := Int (Units.Last - Units.First + 1);
 997
 998       --  Initialize unit table for elaboration control
 999
1000       for U in Units.First .. Units.Last loop
1001          UNR.Increment_Last;
1002          UNR.Table (UNR.Last).Successors    := No_Successor;
1003          UNR.Table (UNR.Last).Num_Pred      := 0;
1004          UNR.Table (UNR.Last).Nextnp        := No_Unit_Id;
1005          UNR.Table (UNR.Last).Elab_Order    := 0;
1006          UNR.Table (UNR.Last).Elab_Position := 0;
1007       end loop;
1008
1009       --  Output warning if -p used with no -gnatE units
1010
1011       if Pessimistic_Elab_Order
1012         and not Dynamic_Elaboration_Checks_Specified
1013       then
1014          if OpenVMS_On_Target then
1015             Error_Msg ("?use of /PESSIMISTIC_ELABORATION questionable");
1016          else
1017             Error_Msg ("?use of -p switch questionable");
1018          end if;
1019
1020          Error_Msg ("?since all units compiled with static elaboration model");
1021       end if;
1022
1023       --  Gather dependencies and output them if option set
1024
1025       Gather_Dependencies;
1026
1027       --  Output elaboration dependencies if option is set
1028
1029       if Elab_Dependency_Output or Debug_Flag_E then
1030          Write_Dependencies;
1031       end if;
1032
1033       --  Initialize the no predecessor list
1034
1035       No_Pred := No_Unit_Id;
1036
1037       for U in UNR.First .. UNR.Last loop
1038          if UNR.Table (U).Num_Pred = 0 then
1039             UNR.Table (U).Nextnp := No_Pred;
1040             No_Pred := U;
1041          end if;
1042       end loop;
1043
1044       --  OK, now we determine the elaboration order proper. All we do is to
1045       --  select the best choice from the no predecessor list until all the
1046       --  nodes have been chosen.
1047
1048       Outer : loop
1049
1050          --  If there are no nodes with predecessors, then either we are
1051          --  done, as indicated by Num_Left being set to zero, or we have
1052          --  a circularity. In the latter case, diagnose the circularity,
1053          --  removing it from the graph and continue
1054
1055          Get_No_Pred : while No_Pred = No_Unit_Id loop
1056             exit Outer when Num_Left < 1;
1057             Diagnose_Elaboration_Problem;
1058          end loop Get_No_Pred;
1059
1060          U := No_Pred;
1061          Best_So_Far := No_Unit_Id;
1062
1063          --  Loop to choose best entry in No_Pred list
1064
1065          No_Pred_Search : loop
1066             if Debug_Flag_N then
1067                Write_Str ("  considering choice of ");
1068                Write_Unit_Name (Units.Table (U).Uname);
1069                Write_Eol;
1070
1071                if Units.Table (U).Elaborate_Body then
1072                   Write_Str
1073                     ("    Elaborate_Body = True, Num_Pred for body = ");
1074                   Write_Int
1075                     (Int (UNR.Table (Corresponding_Body (U)).Num_Pred));
1076                else
1077                   Write_Str
1078                     ("    Elaborate_Body = False");
1079                end if;
1080
1081                Write_Eol;
1082             end if;
1083
1084             --  This is a candididate to be considered for choice
1085
1086             if Best_So_Far = No_Unit_Id
1087               or else ((not Pessimistic_Elab_Order)
1088                          and then Better_Choice (U, Best_So_Far))
1089               or else (Pessimistic_Elab_Order
1090                          and then Worse_Choice (U, Best_So_Far))
1091             then
1092                if Debug_Flag_N then
1093                   Write_Str ("    tentatively chosen (best so far)");
1094                   Write_Eol;
1095                end if;
1096
1097                Best_So_Far := U;
1098             end if;
1099
1100             U := UNR.Table (U).Nextnp;
1101             exit No_Pred_Search when U = No_Unit_Id;
1102          end loop No_Pred_Search;
1103
1104          --  If no candididate chosen, it means that no unit has No_Pred = 0,
1105          --  but there are units left, hence we have a circular dependency,
1106          --  which we will get Diagnose_Elaboration_Problem to diagnose it.
1107
1108          if Best_So_Far = No_Unit_Id then
1109             Diagnose_Elaboration_Problem;
1110
1111          --  Otherwise choose the best candidate found
1112
1113          else
1114             Choose (Best_So_Far);
1115          end if;
1116       end loop Outer;
1117    end Find_Elab_Order;
1118
1119    -------------------------
1120    -- Gather_Dependencies --
1121    -------------------------
1122
1123    procedure Gather_Dependencies is
1124       Withed_Unit : Unit_Id;
1125
1126    begin
1127       --  Loop through all units
1128
1129       for U in Units.First .. Units.Last loop
1130          Cur_Unit := U;
1131
1132          --  If this is not an interface to a stand-alone library and
1133          --  there is a body and a spec, then spec must be elaborated first
1134          --  Note that the corresponding spec immediately follows the body
1135
1136          if not Units.Table (U).SAL_Interface
1137            and then Units.Table (U).Utype = Is_Body
1138          then
1139             Build_Link (Corresponding_Spec (U), U, Spec_First);
1140          end if;
1141
1142          --  If this unit is not an interface to a stand-alone library,
1143          --  process WITH references for this unit ignoring generic units and
1144          --  interfaces to stand-alone libraries.
1145
1146          if not Units.Table (U).SAL_Interface then
1147             for
1148               W in Units.Table (U).First_With .. Units.Table (U).Last_With
1149             loop
1150                if Withs.Table (W).Sfile /= No_File
1151                  and then (not Withs.Table (W).SAL_Interface)
1152                then
1153                   --  Check for special case of withing a unit that does not
1154                   --  exist any more. If the unit was completely missing we
1155                   --  would already have detected this, but a nasty case arises
1156                   --  when we have a subprogram body with no spec, and some
1157                   --  obsolete unit with's a previous (now disappeared) spec.
1158
1159                   if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then
1160                      Error_Msg_File_1 := Units.Table (U).Sfile;
1161                      Error_Msg_Unit_1 := Withs.Table (W).Uname;
1162                      Error_Msg ("{ depends on $ which no longer exists");
1163                      goto Next_With;
1164                   end if;
1165
1166                   Withed_Unit :=
1167                     Unit_Id (Unit_Id_Of (Withs.Table (W).Uname));
1168
1169                   --  Pragma Elaborate_All case, for this we use the recursive
1170                   --  Elab_All_Links procedure to establish the links.
1171
1172                   if Withs.Table (W).Elaborate_All then
1173
1174                      --  Reset flags used to stop multiple visits to a given
1175                      --  node.
1176
1177                      for Uref in UNR.First .. UNR.Last loop
1178                         UNR.Table (Uref).Visited := False;
1179                      end loop;
1180
1181                      --  Now establish all the links we need
1182
1183                      Elab_All_Links
1184                        (Withed_Unit, U, Elab_All,
1185                         Make_Elab_Entry
1186                           (Withs.Table (W).Uname, No_Elab_All_Link));
1187
1188                      --  Elaborate_All_Desirable case, for this we establish
1189                      --  the same links as above, but with a different reason.
1190
1191                   elsif Withs.Table (W).Elab_All_Desirable then
1192
1193                      --  Reset flags used to stop multiple visits to a given
1194                      --  node.
1195
1196                      for Uref in UNR.First .. UNR.Last loop
1197                         UNR.Table (Uref).Visited := False;
1198                      end loop;
1199
1200                      --  Now establish all the links we need
1201
1202                      Elab_All_Links
1203                        (Withed_Unit, U, Elab_All_Desirable,
1204                         Make_Elab_Entry
1205                           (Withs.Table (W).Uname, No_Elab_All_Link));
1206
1207                      --  Pragma Elaborate case. We must build a link for the
1208                      --  withed unit itself, and also the corresponding body
1209                      --  if there is one.
1210
1211                      --  However, skip this processing if there is no ALI file
1212                      --  for the WITH entry, because this means it is a
1213                      --  generic (even when we fix the generics so that an ALI
1214                      --  file is present, we probably still will have no ALI
1215                      --  file for unchecked and other special cases).
1216
1217                   elsif Withs.Table (W).Elaborate
1218                     and then Withs.Table (W).Afile /= No_File
1219                   then
1220                      Build_Link (Withed_Unit, U, Withed);
1221
1222                      if Units.Table (Withed_Unit).Utype = Is_Spec then
1223                         Build_Link
1224                           (Corresponding_Body (Withed_Unit), U, Elab);
1225                      end if;
1226
1227                      --  Elaborate_Desirable case, for this we establish
1228                      --  the same links as above, but with a different reason.
1229
1230                   elsif Withs.Table (W).Elab_Desirable then
1231                      Build_Link (Withed_Unit, U, Withed);
1232
1233                      if Units.Table (Withed_Unit).Utype = Is_Spec then
1234                         Build_Link
1235                           (Corresponding_Body (Withed_Unit),
1236                            U, Elab_Desirable);
1237                      end if;
1238
1239                      --  Case of normal WITH with no elaboration pragmas, just
1240                      --  build the single link to the directly referenced unit
1241
1242                   else
1243                      Build_Link (Withed_Unit, U, Withed);
1244                   end if;
1245                end if;
1246
1247                <<Next_With>>
1248                null;
1249             end loop;
1250          end if;
1251       end loop;
1252    end Gather_Dependencies;
1253
1254    ------------------
1255    -- Is_Body_Unit --
1256    ------------------
1257
1258    function Is_Body_Unit (U : Unit_Id) return Boolean is
1259    begin
1260       return Units.Table (U).Utype = Is_Body
1261         or else Units.Table (U).Utype = Is_Body_Only;
1262    end Is_Body_Unit;
1263
1264    ---------------------
1265    -- Is_Waiting_Body --
1266    ---------------------
1267
1268    function Is_Waiting_Body (U : Unit_Id) return Boolean is
1269    begin
1270       return Units.Table (U).Utype = Is_Body
1271         and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
1272    end Is_Waiting_Body;
1273
1274    ---------------------
1275    -- Make_Elab_Entry --
1276    ---------------------
1277
1278    function Make_Elab_Entry
1279      (Unam : Unit_Name_Type;
1280       Link : Elab_All_Id) return Elab_All_Id
1281    is
1282    begin
1283       Elab_All_Entries.Increment_Last;
1284       Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam;
1285       Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link;
1286       return Elab_All_Entries.Last;
1287    end Make_Elab_Entry;
1288
1289    ----------------
1290    -- Unit_Id_Of --
1291    ----------------
1292
1293    function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
1294       Info : constant Int := Get_Name_Table_Info (Uname);
1295    begin
1296       pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
1297       return Unit_Id (Info);
1298    end Unit_Id_Of;
1299
1300    ------------------
1301    -- Worse_Choice --
1302    ------------------
1303
1304    function Worse_Choice (U1, U2 : Unit_Id) return Boolean is
1305       UT1 : Unit_Record renames Units.Table (U1);
1306       UT2 : Unit_Record renames Units.Table (U2);
1307
1308    begin
1309       --  Note: the checks here are applied in sequence, and the ordering is
1310       --  significant (i.e. the more important criteria are applied first).
1311
1312       --  If either unit is internal, then use Better_Choice, since the
1313       --  language requires that predefined units not mess up in the choice
1314       --  of elaboration order, and for internal units, any problems are
1315       --  ours and not the programmers.
1316
1317       if UT1.Internal or else UT2.Internal then
1318          return Better_Choice (U1, U2);
1319
1320       --  Prefer anything else to a waiting body (!)
1321
1322       elsif Is_Waiting_Body (U1) and not Is_Waiting_Body (U2) then
1323          return False;
1324
1325       elsif Is_Waiting_Body (U2) and not Is_Waiting_Body (U1) then
1326          return True;
1327
1328       --  Prefer a spec to a body (!)
1329
1330       elsif Is_Body_Unit (U1) and not Is_Body_Unit (U2) then
1331          return False;
1332
1333       elsif Is_Body_Unit (U2) and not Is_Body_Unit (U1) then
1334          return True;
1335
1336       --  If both are waiting bodies, then prefer the one whose spec is
1337       --  less recently elaborated. Consider the following:
1338
1339       --     spec of A
1340       --     spec of B
1341       --     body of A or B?
1342
1343       --  The normal waiting body preference would have placed the body of
1344       --  A before the spec of B if it could. Since it could not, there it
1345       --  must be the case that A depends on B. It is therefore a good idea
1346       --  to put the body of B last so that if there is an elaboration order
1347       --  problem, we will find it (that's what horrible order is about)
1348
1349       elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
1350          return
1351            UNR.Table (Corresponding_Spec (U1)).Elab_Position <
1352            UNR.Table (Corresponding_Spec (U2)).Elab_Position;
1353       end if;
1354
1355       --  Remaining choice rules are disabled by Debug flag -do
1356
1357       if not Debug_Flag_O then
1358
1359          --  The following deal with the case of specs which have been marked
1360          --  as Elaborate_Body_Desirable. In the normal case, we generally want
1361          --  to delay the elaboration of these specs as long as possible, so
1362          --  that bodies have better chance of being elaborated closer to the
1363          --  specs. Worse_Choice as usual wants to do the opposite and
1364          --  elaborate such specs as early as possible.
1365
1366          --  If we have two units, one of which is a spec for which this flag
1367          --  is set, and the other is not, we normally prefer to delay the spec
1368          --  for which the flag is set, and so Worse_Choice does the opposite.
1369
1370          if not UT1.Elaborate_Body_Desirable
1371            and then UT2.Elaborate_Body_Desirable
1372          then
1373             return False;
1374
1375          elsif not UT2.Elaborate_Body_Desirable
1376            and then UT1.Elaborate_Body_Desirable
1377          then
1378             return True;
1379
1380             --  If we have two specs that are both marked as Elaborate_Body
1381             --  desirable, we normally prefer the one whose body is nearer to
1382             --  being able to be elaborated, based on the Num_Pred count. This
1383             --  helps to ensure bodies are as close to specs as possible. As
1384             --  usual, Worse_Choice does the opposite.
1385
1386          elsif UT1.Elaborate_Body_Desirable
1387            and then UT2.Elaborate_Body_Desirable
1388          then
1389             return UNR.Table (Corresponding_Body (U1)).Num_Pred >=
1390               UNR.Table (Corresponding_Body (U2)).Num_Pred;
1391          end if;
1392       end if;
1393
1394       --  If we fall through, it means that no preference rule applies, so we
1395       --  use alphabetical order to at least give a deterministic result. Since
1396       --  Worse_Choice is in the business of stirring up the order, we will
1397       --  use reverse alphabetical ordering.
1398
1399       return Uname_Less (UT2.Uname, UT1.Uname);
1400    end Worse_Choice;
1401
1402    ------------------------
1403    -- Write_Dependencies --
1404    ------------------------
1405
1406    procedure Write_Dependencies is
1407    begin
1408       if not Zero_Formatting then
1409          Write_Eol;
1410          Write_Str ("                 ELABORATION ORDER DEPENDENCIES");
1411          Write_Eol;
1412          Write_Eol;
1413       end if;
1414
1415       Info_Prefix_Suppress := True;
1416
1417       for S in Succ_First .. Succ.Last loop
1418          Elab_Error_Msg (S);
1419       end loop;
1420
1421       Info_Prefix_Suppress := False;
1422
1423       if not Zero_Formatting then
1424          Write_Eol;
1425       end if;
1426    end Write_Dependencies;
1427
1428    --------------------------
1429    -- Write_Elab_All_Chain --
1430    --------------------------
1431
1432    procedure Write_Elab_All_Chain (S : Successor_Id) is
1433       ST     : constant Successor_Link := Succ.Table (S);
1434       After  : constant Unit_Name_Type := Units.Table (ST.After).Uname;
1435
1436       L   : Elab_All_Id;
1437       Nam : Unit_Name_Type;
1438
1439       First_Name : Boolean := True;
1440
1441    begin
1442       if ST.Reason in Elab_All .. Elab_All_Desirable then
1443          L := ST.Elab_All_Link;
1444          while L /= No_Elab_All_Link loop
1445             Nam := Elab_All_Entries.Table (L).Needed_By;
1446             Error_Msg_Unit_1 := Nam;
1447             Error_Msg_Output ("        $", Info => True);
1448
1449             Get_Name_String (Nam);
1450
1451             if Name_Buffer (Name_Len) = 'b' then
1452                if First_Name then
1453                   Error_Msg_Output
1454                     ("           must be elaborated along with its spec:",
1455                      Info => True);
1456
1457                else
1458                   Error_Msg_Output
1459                     ("           which must be elaborated " &
1460                      "along with its spec:",
1461                      Info => True);
1462                end if;
1463
1464             else
1465                if First_Name then
1466                   Error_Msg_Output
1467                     ("           is withed by:",
1468                      Info => True);
1469
1470                else
1471                   Error_Msg_Output
1472                     ("           which is withed by:",
1473                      Info => True);
1474                end if;
1475             end if;
1476
1477             First_Name := False;
1478
1479             L := Elab_All_Entries.Table (L).Next_Elab;
1480          end loop;
1481
1482          Error_Msg_Unit_1 := After;
1483          Error_Msg_Output ("        $", Info => True);
1484       end if;
1485    end Write_Elab_All_Chain;
1486
1487 end Binde;