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