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