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-2010, 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, and
 228    --  the reason for the link is R. Ea_Id is the contents to be placed in the
 229    --  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 procedure
 233    --  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, return
 238    --  the unit id of the body. It is an error to call this routine with a unit
 239    --  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, return
 244    --  the unit id of the spec. It is an error to call this routine with a unit
 245    --  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_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean;
 280    --  Returns True if corresponding unit is Pure or Preelaborate. Includes
 281    --  dealing with testing flags on spec if it is given a body.
 282
 283    function Is_Waiting_Body (U : Unit_Id) return Boolean;
 284    pragma Inline (Is_Waiting_Body);
 285    --  Determines if U is a waiting body, defined as a body which has
 286    --  not been elaborated, but whose spec has been elaborated.
 287
 288    function Make_Elab_Entry
 289      (Unam : Unit_Name_Type;
 290       Link : Elab_All_Id) return Elab_All_Id;
 291    --  Make an Elab_All_Entries table entry with the given Unam and Link
 292
 293    function Pessimistic_Better_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 -p (pessimistic
 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    function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id;
 300    --  This function uses the Info field set in the names table to obtain
 301    --  the unit Id of a unit, given its name id value.
 302
 303    procedure Write_Dependencies;
 304    --  Write out dependencies (called only if appropriate option is set)
 305
 306    procedure Write_Elab_All_Chain (S : Successor_Id);
 307    --  If the reason for the link S is Elaborate_All or Elaborate_Desirable,
 308    --  then this routine will output the "needed by" explanation chain.
 309
 310    -------------------
 311    -- Better_Choice --
 312    -------------------
 313
 314    function Better_Choice (U1, U2 : Unit_Id) return Boolean is
 315       UT1 : Unit_Record renames Units.Table (U1);
 316       UT2 : Unit_Record renames Units.Table (U2);
 317
 318    begin
 319       if Debug_Flag_B then
 320          Write_Str ("Better_Choice (");
 321          Write_Unit_Name (UT1.Uname);
 322          Write_Str (", ");
 323          Write_Unit_Name (UT2.Uname);
 324          Write_Line (")");
 325       end if;
 326
 327       --  Note: the checks here are applied in sequence, and the ordering is
 328       --  significant (i.e. the more important criteria are applied first).
 329
 330       --  Prefer a waiting body to one that is not a waiting body
 331
 332       if Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
 333          if Debug_Flag_B then
 334             Write_Line ("  True: u1 is waiting body, u2 is not");
 335          end if;
 336
 337          return True;
 338
 339       elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
 340          if Debug_Flag_B then
 341             Write_Line ("  False: u2 is waiting body, u1 is not");
 342          end if;
 343
 344          return False;
 345
 346       --  Prefer a predefined unit to a non-predefined unit
 347
 348       elsif UT1.Predefined and then not UT2.Predefined then
 349          if Debug_Flag_B then
 350             Write_Line ("  True: u1 is predefined, u2 is not");
 351          end if;
 352
 353          return True;
 354
 355       elsif UT2.Predefined and then not UT1.Predefined then
 356          if Debug_Flag_B then
 357             Write_Line ("  False: u2 is predefined, u1 is not");
 358          end if;
 359
 360          return False;
 361
 362       --  Prefer an internal unit to a non-internal unit
 363
 364       elsif UT1.Internal and then not UT2.Internal then
 365          if Debug_Flag_B then
 366             Write_Line ("  True: u1 is internal, u2 is not");
 367          end if;
 368          return True;
 369
 370       elsif UT2.Internal and then not UT1.Internal then
 371          if Debug_Flag_B then
 372             Write_Line ("  False: u2 is internal, u1 is not");
 373          end if;
 374
 375          return False;
 376
 377       --  Prefer a pure or preelaborable unit to one that is not
 378
 379       elsif Is_Pure_Or_Preelab_Unit (U1)
 380               and then not
 381             Is_Pure_Or_Preelab_Unit (U2)
 382       then
 383          if Debug_Flag_B then
 384             Write_Line ("  True: u1 is pure/preelab, u2 is not");
 385          end if;
 386
 387          return True;
 388
 389       elsif Is_Pure_Or_Preelab_Unit (U2)
 390               and then not
 391             Is_Pure_Or_Preelab_Unit (U1)
 392       then
 393          if Debug_Flag_B then
 394             Write_Line ("  False: u2 is pure/preelab, u1 is not");
 395          end if;
 396
 397          return False;
 398
 399       --  Prefer a body to a spec
 400
 401       elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
 402          if Debug_Flag_B then
 403             Write_Line ("  True: u1 is body, u2 is not");
 404          end if;
 405
 406          return True;
 407
 408       elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
 409          if Debug_Flag_B then
 410             Write_Line ("  False: u2 is body, u1 is not");
 411          end if;
 412
 413          return False;
 414
 415       --  If both are waiting bodies, then prefer the one whose spec is
 416       --  more recently elaborated. Consider the following:
 417
 418       --     spec of A
 419       --     spec of B
 420       --     body of A or B?
 421
 422       --  The normal waiting body preference would have placed the body of
 423       --  A before the spec of B if it could. Since it could not, there it
 424       --  must be the case that A depends on B. It is therefore a good idea
 425       --  to put the body of B first.
 426
 427       elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
 428          declare
 429             Result : constant Boolean :=
 430                        UNR.Table (Corresponding_Spec (U1)).Elab_Position >
 431                        UNR.Table (Corresponding_Spec (U2)).Elab_Position;
 432          begin
 433             if Debug_Flag_B then
 434                if Result then
 435                   Write_Line ("  True: based on waiting body elab positions");
 436                else
 437                   Write_Line ("  False: based on waiting body elab positions");
 438                end if;
 439             end if;
 440
 441             return Result;
 442          end;
 443       end if;
 444
 445       --  Remaining choice rules are disabled by Debug flag -do
 446
 447       if not Debug_Flag_O then
 448
 449          --  The following deal with the case of specs which have been marked
 450          --  as Elaborate_Body_Desirable. We generally want to delay these
 451          --  specs as long as possible, so that the bodies have a better chance
 452          --  of being elaborated closer to the specs.
 453
 454          --  If we have two units, one of which is a spec for which this flag
 455          --  is set, and the other is not, we prefer to delay the spec for
 456          --  which the flag is set.
 457
 458          if not UT1.Elaborate_Body_Desirable
 459            and then UT2.Elaborate_Body_Desirable
 460          then
 461             if Debug_Flag_B then
 462                Write_Line ("  True: u1 is elab body desirable, u2 is not");
 463             end if;
 464
 465             return True;
 466
 467          elsif not UT2.Elaborate_Body_Desirable
 468            and then UT1.Elaborate_Body_Desirable
 469          then
 470             if Debug_Flag_B then
 471                Write_Line ("  False: u1 is elab body desirable, u2 is not");
 472             end if;
 473
 474             return False;
 475
 476             --  If we have two specs that are both marked as Elaborate_Body
 477             --  desirable, we prefer the one whose body is nearer to being able
 478             --  to be elaborated, based on the Num_Pred count. This helps to
 479             --  ensure bodies are as close to specs as possible.
 480
 481          elsif UT1.Elaborate_Body_Desirable
 482            and then UT2.Elaborate_Body_Desirable
 483          then
 484             declare
 485                Result : constant Boolean :=
 486                           UNR.Table (Corresponding_Body (U1)).Num_Pred <
 487                           UNR.Table (Corresponding_Body (U2)).Num_Pred;
 488             begin
 489                if Debug_Flag_B then
 490                   if Result then
 491                      Write_Line ("  True based on Num_Pred compare");
 492                   else
 493                      Write_Line ("  False based on Num_Pred compare");
 494                   end if;
 495                end if;
 496
 497                return Result;
 498             end;
 499          end if;
 500       end if;
 501
 502       --  If we fall through, it means that no preference rule applies, so we
 503       --  use alphabetical order to at least give a deterministic result.
 504
 505       if Debug_Flag_B then
 506          Write_Line ("  choose on alpha order");
 507       end if;
 508
 509       return Uname_Less (UT1.Uname, UT2.Uname);
 510    end Better_Choice;
 511
 512    ----------------
 513    -- Build_Link --
 514    ----------------
 515
 516    procedure Build_Link
 517      (Before : Unit_Id;
 518       After  : Unit_Id;
 519       R      : Succ_Reason;
 520       Ea_Id  : Elab_All_Id := No_Elab_All_Link)
 521    is
 522       Cspec : Unit_Id;
 523
 524    begin
 525       Succ.Increment_Last;
 526       Succ.Table (Succ.Last).Before          := Before;
 527       Succ.Table (Succ.Last).Next            := UNR.Table (Before).Successors;
 528       UNR.Table (Before).Successors          := Succ.Last;
 529       Succ.Table (Succ.Last).Reason          := R;
 530       Succ.Table (Succ.Last).Reason_Unit     := Cur_Unit;
 531       Succ.Table (Succ.Last).Elab_All_Link   := Ea_Id;
 532
 533       --  Deal with special Elab_Body case. If the After of this link is
 534       --  a body whose spec has Elaborate_All set, and this is not the link
 535       --  directly from the body to the spec, then we make the After of the
 536       --  link reference its spec instead, marking the link appropriately.
 537
 538       if Units.Table (After).Utype = Is_Body then
 539          Cspec := Corresponding_Spec (After);
 540
 541          if Units.Table (Cspec).Elaborate_Body
 542            and then Cspec /= Before
 543          then
 544             Succ.Table (Succ.Last).After     := Cspec;
 545             Succ.Table (Succ.Last).Elab_Body := True;
 546             UNR.Table (Cspec).Num_Pred       := UNR.Table (Cspec).Num_Pred + 1;
 547             return;
 548          end if;
 549       end if;
 550
 551       --  Fall through on normal case
 552
 553       Succ.Table (Succ.Last).After           := After;
 554       Succ.Table (Succ.Last).Elab_Body       := False;
 555       UNR.Table (After).Num_Pred             := UNR.Table (After).Num_Pred + 1;
 556    end Build_Link;
 557
 558    ------------
 559    -- Choose --
 560    ------------
 561
 562    procedure Choose (Chosen : Unit_Id) is
 563       S : Successor_Id;
 564       U : Unit_Id;
 565
 566    begin
 567       if Debug_Flag_C then
 568          Write_Str ("Choosing Unit ");
 569          Write_Unit_Name (Units.Table (Chosen).Uname);
 570          Write_Eol;
 571       end if;
 572
 573       --  Add to elaboration order. Note that units having no elaboration
 574       --  code are not treated specially yet. The special casing of this
 575       --  is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile
 576       --  we need them here, because the object file list is also driven
 577       --  by the contents of the Elab_Order table.
 578
 579       Elab_Order.Increment_Last;
 580       Elab_Order.Table (Elab_Order.Last) := Chosen;
 581
 582       --  Remove from No_Pred list. This is a little inefficient and may
 583       --  be we should doubly link the list, but it will do for now!
 584
 585       if No_Pred = Chosen then
 586          No_Pred := UNR.Table (Chosen).Nextnp;
 587
 588       else
 589          --  Note that we just ignore the situation where it does not
 590          --  appear in the No_Pred list, this happens in calls from the
 591          --  Diagnose_Elaboration_Problem routine, where cycles are being
 592          --  removed arbitrarily from the graph.
 593
 594          U := No_Pred;
 595          while U /= No_Unit_Id loop
 596             if UNR.Table (U).Nextnp = Chosen then
 597                UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp;
 598                exit;
 599             end if;
 600
 601             U := UNR.Table (U).Nextnp;
 602          end loop;
 603       end if;
 604
 605       --  For all successors, decrement the number of predecessors, and
 606       --  if it becomes zero, then add to no predecessor list.
 607
 608       S := UNR.Table (Chosen).Successors;
 609       while S /= No_Successor loop
 610          U := Succ.Table (S).After;
 611          UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1;
 612
 613          if Debug_Flag_N then
 614             Write_Str ("  decrementing Num_Pred for unit ");
 615             Write_Unit_Name (Units.Table (U).Uname);
 616             Write_Str (" new value = ");
 617             Write_Int (UNR.Table (U).Num_Pred);
 618             Write_Eol;
 619          end if;
 620
 621          if UNR.Table (U).Num_Pred = 0 then
 622             UNR.Table (U).Nextnp := No_Pred;
 623             No_Pred := U;
 624          end if;
 625
 626          S := Succ.Table (S).Next;
 627       end loop;
 628
 629       --  All done, adjust number of units left count and set elaboration pos
 630
 631       Num_Left := Num_Left - 1;
 632       Num_Chosen := Num_Chosen + 1;
 633       UNR.Table (Chosen).Elab_Position := Num_Chosen;
 634       Units.Table (Chosen).Elab_Position := Num_Chosen;
 635
 636       --  If we just chose a spec with Elaborate_Body set, then we
 637       --  must immediately elaborate the body, before any other units.
 638
 639       if Units.Table (Chosen).Elaborate_Body then
 640
 641          --  If the unit is a spec only, then there is no body. This is a bit
 642          --  odd given that Elaborate_Body is here, but it is valid in an
 643          --  RCI unit, where we only have the interface in the stub bind.
 644
 645          if Units.Table (Chosen).Utype = Is_Spec_Only
 646            and then Units.Table (Chosen).RCI
 647          then
 648             null;
 649          else
 650             Choose (Corresponding_Body (Chosen));
 651          end if;
 652       end if;
 653    end Choose;
 654
 655    ------------------------
 656    -- Corresponding_Body --
 657    ------------------------
 658
 659    --  Currently if the body and spec are separate, then they appear as
 660    --  two separate units in the same ALI file, with the body appearing
 661    --  first and the spec appearing second.
 662
 663    function Corresponding_Body (U : Unit_Id) return Unit_Id is
 664    begin
 665       pragma Assert (Units.Table (U).Utype = Is_Spec);
 666       return U - 1;
 667    end Corresponding_Body;
 668
 669    ------------------------
 670    -- Corresponding_Spec --
 671    ------------------------
 672
 673    --  Currently if the body and spec are separate, then they appear as
 674    --  two separate units in the same ALI file, with the body appearing
 675    --  first and the spec appearing second.
 676
 677    function Corresponding_Spec (U : Unit_Id) return Unit_Id is
 678    begin
 679       pragma Assert (Units.Table (U).Utype = Is_Body);
 680       return U + 1;
 681    end Corresponding_Spec;
 682
 683    ----------------------------------
 684    -- Diagnose_Elaboration_Problem --
 685    ----------------------------------
 686
 687    procedure Diagnose_Elaboration_Problem is
 688
 689       function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean;
 690       --  Recursive routine used to find a path from node Ufrom to node Uto.
 691       --  If a path exists, returns True and outputs an appropriate set of
 692       --  error messages giving the path. Also calls Choose for each of the
 693       --  nodes so that they get removed from the remaining set. There are
 694       --  two cases of calls, either Ufrom = Uto for an attempt to find a
 695       --  cycle, or Ufrom is a spec and Uto the corresponding body for the
 696       --  case of an unsatisfiable Elaborate_Body pragma. ML is the minimum
 697       --  acceptable length for a path.
 698
 699       ---------------
 700       -- Find_Path --
 701       ---------------
 702
 703       function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is
 704
 705          function Find_Link (U : Unit_Id; PL : Nat) return Boolean;
 706          --  This is the inner recursive routine, it determines if a path
 707          --  exists from U to Uto, and if so returns True and outputs the
 708          --  appropriate set of error messages. PL is the path length
 709
 710          ---------------
 711          -- Find_Link --
 712          ---------------
 713
 714          function Find_Link (U : Unit_Id; PL : Nat) return Boolean is
 715             S : Successor_Id;
 716
 717          begin
 718             --  Recursion ends if we are at terminating node and the path
 719             --  is sufficiently long, generate error message and return True.
 720
 721             if U = Uto and then PL >= ML then
 722                Choose (U);
 723                return True;
 724
 725             --  All done if already visited, otherwise mark as visited
 726
 727             elsif UNR.Table (U).Visited then
 728                return False;
 729
 730             --  Otherwise mark as visited and look at all successors
 731
 732             else
 733                UNR.Table (U).Visited := True;
 734
 735                S := UNR.Table (U).Successors;
 736                while S /= No_Successor loop
 737                   if Find_Link (Succ.Table (S).After, PL + 1) then
 738                      Elab_Error_Msg (S);
 739                      Choose (U);
 740                      return True;
 741                   end if;
 742
 743                   S := Succ.Table (S).Next;
 744                end loop;
 745
 746                --  Falling through means this does not lead to a path
 747
 748                return False;
 749             end if;
 750          end Find_Link;
 751
 752       --  Start of processing for Find_Path
 753
 754       begin
 755          --  Initialize all non-chosen nodes to not visisted yet
 756
 757          for U in Units.First .. Units.Last loop
 758             UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0;
 759          end loop;
 760
 761          --  Now try to find the path
 762
 763          return Find_Link (Ufrom, 0);
 764       end Find_Path;
 765
 766    --  Start of processing for Diagnose_Elaboration_Error
 767
 768    begin
 769       Set_Standard_Error;
 770
 771       --  Output state of things if debug flag N set
 772
 773       if Debug_Flag_N then
 774          declare
 775             NP : Int;
 776
 777          begin
 778             Write_Eol;
 779             Write_Eol;
 780             Write_Str ("Diagnose_Elaboration_Problem called");
 781             Write_Eol;
 782             Write_Str ("List of remaining unchosen units and predecessors");
 783             Write_Eol;
 784
 785             for U in Units.First .. Units.Last loop
 786                if UNR.Table (U).Elab_Position = 0 then
 787                   NP := UNR.Table (U).Num_Pred;
 788                   Write_Eol;
 789                   Write_Str ("  Unchosen unit: #");
 790                   Write_Int (Int (U));
 791                   Write_Str ("  ");
 792                   Write_Unit_Name (Units.Table (U).Uname);
 793                   Write_Str (" (Num_Pred = ");
 794                   Write_Int (NP);
 795                   Write_Char (')');
 796                   Write_Eol;
 797
 798                   if NP = 0 then
 799                      if Units.Table (U).Elaborate_Body then
 800                         Write_Str
 801                           ("    (not chosen because of Elaborate_Body)");
 802                         Write_Eol;
 803                      else
 804                         Write_Str ("  ****************** why not chosen?");
 805                         Write_Eol;
 806                      end if;
 807                   end if;
 808
 809                   --  Search links list to find unchosen predecessors
 810
 811                   for S in Succ.First .. Succ.Last loop
 812                      declare
 813                         SL : Successor_Link renames Succ.Table (S);
 814
 815                      begin
 816                         if SL.After = U
 817                           and then UNR.Table (SL.Before).Elab_Position = 0
 818                         then
 819                            Write_Str ("    unchosen predecessor: #");
 820                            Write_Int (Int (SL.Before));
 821                            Write_Str ("  ");
 822                            Write_Unit_Name (Units.Table (SL.Before).Uname);
 823                            Write_Eol;
 824                            NP := NP - 1;
 825                         end if;
 826                      end;
 827                   end loop;
 828
 829                   if NP /= 0 then
 830                      Write_Str ("  **************** Num_Pred value wrong!");
 831                      Write_Eol;
 832                   end if;
 833                end if;
 834             end loop;
 835          end;
 836       end if;
 837
 838       --  Output the header for the error, and manually increment the
 839       --  error count. We are using Error_Msg_Output rather than Error_Msg
 840       --  here for two reasons:
 841
 842       --    This is really only one error, not one for each line
 843       --    We want this output on standard output since it is voluminous
 844
 845       --  But we do need to deal with the error count manually in this case
 846
 847       Errors_Detected := Errors_Detected + 1;
 848       Error_Msg_Output ("elaboration circularity detected", Info => False);
 849
 850       --  Try to find cycles starting with any of the remaining nodes that have
 851       --  not yet been chosen. There must be at least one (there is some reason
 852       --  we are being called!)
 853
 854       for U in Units.First .. Units.Last loop
 855          if UNR.Table (U).Elab_Position = 0 then
 856             if Find_Path (U, U, 1) then
 857                raise Unrecoverable_Error;
 858             end if;
 859          end if;
 860       end loop;
 861
 862       --  We should never get here, since we were called for some reason,
 863       --  and we should have found and eliminated at least one bad path.
 864
 865       raise Program_Error;
 866    end Diagnose_Elaboration_Problem;
 867
 868    --------------------
 869    -- Elab_All_Links --
 870    --------------------
 871
 872    procedure Elab_All_Links
 873      (Before : Unit_Id;
 874       After  : Unit_Id;
 875       Reason : Succ_Reason;
 876       Link   : Elab_All_Id)
 877    is
 878    begin
 879       if UNR.Table (Before).Visited then
 880          return;
 881       end if;
 882
 883       --  Build the direct link for Before
 884
 885       UNR.Table (Before).Visited := True;
 886       Build_Link (Before, After, Reason, Link);
 887
 888       --  Process all units with'ed by Before recursively
 889
 890       for W in
 891         Units.Table (Before).First_With .. Units.Table (Before).Last_With
 892       loop
 893          --  Skip if this with is an interface to a stand-alone library.
 894          --  Skip also if no ALI file for this WITH, happens for language
 895          --  defined generics while bootstrapping the compiler (see body of
 896          --  Lib.Writ.Write_With_Lines). Finally, skip if it is a limited
 897          --  with clause, which does not impose an elaboration link.
 898
 899          if not Withs.Table (W).SAL_Interface
 900            and then Withs.Table (W).Afile /= No_File
 901            and then not Withs.Table (W).Limited_With
 902          then
 903             declare
 904                Info : constant Int :=
 905                         Get_Name_Table_Info
 906                           (Withs.Table (W).Uname);
 907
 908             begin
 909                --  If the unit is unknown, for some unknown reason, fail
 910                --  graciously explaining that the unit is unknown. Without
 911                --  this check, gnatbind will crash in Unit_Id_Of.
 912
 913                if Info = 0 or else Unit_Id (Info) = No_Unit_Id then
 914                   declare
 915                      Withed       : String :=
 916                                       Get_Name_String (Withs.Table (W).Uname);
 917                      Last_Withed  : Natural := Withed'Last;
 918                      Withing      : String :=
 919                                       Get_Name_String
 920                                         (Units.Table (Before).Uname);
 921                      Last_Withing : Natural := Withing'Last;
 922                      Spec_Body    : String  := " (Spec)";
 923
 924                   begin
 925                      To_Mixed (Withed);
 926                      To_Mixed (Withing);
 927
 928                      if Last_Withed > 2 and then
 929                        Withed (Last_Withed - 1) = '%'
 930                      then
 931                         Last_Withed := Last_Withed - 2;
 932                      end if;
 933
 934                      if Last_Withing > 2 and then
 935                        Withing (Last_Withing - 1) = '%'
 936                      then
 937                         Last_Withing := Last_Withing - 2;
 938                      end if;
 939
 940                      if Units.Table (Before).Utype = Is_Body or else
 941                        Units.Table (Before).Utype = Is_Body_Only
 942                      then
 943                         Spec_Body := " (Body)";
 944                      end if;
 945
 946                      Osint.Fail
 947                        ("could not find unit "
 948                         & Withed (Withed'First .. Last_Withed) & " needed by "
 949                         & Withing (Withing'First .. Last_Withing) & Spec_Body);
 950                   end;
 951                end if;
 952
 953                Elab_All_Links
 954                  (Unit_Id_Of (Withs.Table (W).Uname),
 955                   After,
 956                   Reason,
 957                   Make_Elab_Entry (Withs.Table (W).Uname, Link));
 958             end;
 959          end if;
 960       end loop;
 961
 962       --  Process corresponding body, if there is one
 963
 964       if Units.Table (Before).Utype = Is_Spec then
 965          Elab_All_Links
 966            (Corresponding_Body (Before),
 967             After, Reason,
 968             Make_Elab_Entry
 969               (Units.Table (Corresponding_Body (Before)).Uname, Link));
 970       end if;
 971    end Elab_All_Links;
 972
 973    --------------------
 974    -- Elab_Error_Msg --
 975    --------------------
 976
 977    procedure Elab_Error_Msg (S : Successor_Id) is
 978       SL : Successor_Link renames Succ.Table (S);
 979
 980    begin
 981       --  Nothing to do if internal unit involved and no -da flag
 982
 983       if not Debug_Flag_A
 984         and then
 985           (Is_Internal_File_Name (Units.Table (SL.Before).Sfile)
 986             or else
 987            Is_Internal_File_Name (Units.Table (SL.After).Sfile))
 988       then
 989          return;
 990       end if;
 991
 992       --  Here we want to generate output
 993
 994       Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
 995
 996       if SL.Elab_Body then
 997          Error_Msg_Unit_2 := Units.Table (Corresponding_Body (SL.After)).Uname;
 998       else
 999          Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
1000       end if;
1001
1002       Error_Msg_Output ("  $ must be elaborated before $", Info => True);
1003
1004       Error_Msg_Unit_1 := Units.Table (SL.Reason_Unit).Uname;
1005
1006       case SL.Reason is
1007          when Withed =>
1008             Error_Msg_Output
1009               ("     reason: with clause",
1010                Info => True);
1011
1012          when Elab =>
1013             Error_Msg_Output
1014               ("     reason: pragma Elaborate in unit $",
1015                Info => True);
1016
1017          when Elab_All =>
1018             Error_Msg_Output
1019               ("     reason: pragma Elaborate_All in unit $",
1020                Info => True);
1021
1022          when Elab_All_Desirable =>
1023             Error_Msg_Output
1024               ("     reason: implicit Elaborate_All in unit $",
1025                Info => True);
1026
1027             Error_Msg_Output
1028               ("     recompile $ with -gnatwl for full details",
1029                Info => True);
1030
1031          when Elab_Desirable =>
1032             Error_Msg_Output
1033               ("     reason: implicit Elaborate in unit $",
1034                Info => True);
1035
1036             Error_Msg_Output
1037               ("     recompile $ with -gnatwl for full details",
1038                Info => True);
1039
1040          when Spec_First =>
1041             Error_Msg_Output
1042               ("     reason: spec always elaborated before body",
1043                Info => True);
1044       end case;
1045
1046       Write_Elab_All_Chain (S);
1047
1048       if SL.Elab_Body then
1049          Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
1050          Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
1051          Error_Msg_Output
1052            ("  $ must therefore be elaborated before $",
1053             True);
1054
1055          Error_Msg_Unit_1 := Units.Table (SL.After).Uname;
1056          Error_Msg_Output
1057            ("     (because $ has a pragma Elaborate_Body)",
1058             True);
1059       end if;
1060
1061       if not Zero_Formatting then
1062          Write_Eol;
1063       end if;
1064    end Elab_Error_Msg;
1065
1066    ---------------------
1067    -- Find_Elab_Order --
1068    ---------------------
1069
1070    procedure Find_Elab_Order is
1071       U           : Unit_Id;
1072       Best_So_Far : Unit_Id;
1073
1074    begin
1075       Succ.Init;
1076       Num_Left := Int (Units.Last - Units.First + 1);
1077
1078       --  Initialize unit table for elaboration control
1079
1080       for U in Units.First .. Units.Last loop
1081          UNR.Increment_Last;
1082          UNR.Table (UNR.Last).Successors    := No_Successor;
1083          UNR.Table (UNR.Last).Num_Pred      := 0;
1084          UNR.Table (UNR.Last).Nextnp        := No_Unit_Id;
1085          UNR.Table (UNR.Last).Elab_Order    := 0;
1086          UNR.Table (UNR.Last).Elab_Position := 0;
1087       end loop;
1088
1089       --  Output warning if -p used with no -gnatE units
1090
1091       if Pessimistic_Elab_Order
1092         and not Dynamic_Elaboration_Checks_Specified
1093       then
1094          if OpenVMS_On_Target then
1095             Error_Msg ("?use of /PESSIMISTIC_ELABORATION questionable");
1096          else
1097             Error_Msg ("?use of -p switch questionable");
1098          end if;
1099
1100          Error_Msg ("?since all units compiled with static elaboration model");
1101       end if;
1102
1103       --  Gather dependencies and output them if option set
1104
1105       Gather_Dependencies;
1106
1107       --  Output elaboration dependencies if option is set
1108
1109       if Elab_Dependency_Output or Debug_Flag_E then
1110          Write_Dependencies;
1111       end if;
1112
1113       --  Initialize the no predecessor list
1114
1115       No_Pred := No_Unit_Id;
1116
1117       for U in UNR.First .. UNR.Last loop
1118          if UNR.Table (U).Num_Pred = 0 then
1119             UNR.Table (U).Nextnp := No_Pred;
1120             No_Pred := U;
1121          end if;
1122       end loop;
1123
1124       --  OK, now we determine the elaboration order proper. All we do is to
1125       --  select the best choice from the no predecessor list until all the
1126       --  nodes have been chosen.
1127
1128       Outer : loop
1129
1130          --  If there are no nodes with predecessors, then either we are
1131          --  done, as indicated by Num_Left being set to zero, or we have
1132          --  a circularity. In the latter case, diagnose the circularity,
1133          --  removing it from the graph and continue
1134
1135          Get_No_Pred : while No_Pred = No_Unit_Id loop
1136             exit Outer when Num_Left < 1;
1137             Diagnose_Elaboration_Problem;
1138          end loop Get_No_Pred;
1139
1140          U := No_Pred;
1141          Best_So_Far := No_Unit_Id;
1142
1143          --  Loop to choose best entry in No_Pred list
1144
1145          No_Pred_Search : loop
1146             if Debug_Flag_N then
1147                Write_Str ("  considering choice of ");
1148                Write_Unit_Name (Units.Table (U).Uname);
1149                Write_Eol;
1150
1151                if Units.Table (U).Elaborate_Body then
1152                   Write_Str
1153                     ("    Elaborate_Body = True, Num_Pred for body = ");
1154                   Write_Int
1155                     (UNR.Table (Corresponding_Body (U)).Num_Pred);
1156                else
1157                   Write_Str
1158                     ("    Elaborate_Body = False");
1159                end if;
1160
1161                Write_Eol;
1162             end if;
1163
1164             --  This is a candididate to be considered for choice
1165
1166             if Best_So_Far = No_Unit_Id
1167               or else ((not Pessimistic_Elab_Order)
1168                          and then Better_Choice (U, Best_So_Far))
1169               or else (Pessimistic_Elab_Order
1170                          and then Pessimistic_Better_Choice (U, Best_So_Far))
1171             then
1172                if Debug_Flag_N then
1173                   Write_Str ("    tentatively chosen (best so far)");
1174                   Write_Eol;
1175                end if;
1176
1177                Best_So_Far := U;
1178             end if;
1179
1180             U := UNR.Table (U).Nextnp;
1181             exit No_Pred_Search when U = No_Unit_Id;
1182          end loop No_Pred_Search;
1183
1184          --  If no candididate chosen, it means that no unit has No_Pred = 0,
1185          --  but there are units left, hence we have a circular dependency,
1186          --  which we will get Diagnose_Elaboration_Problem to diagnose it.
1187
1188          if Best_So_Far = No_Unit_Id then
1189             Diagnose_Elaboration_Problem;
1190
1191          --  Otherwise choose the best candidate found
1192
1193          else
1194             Choose (Best_So_Far);
1195          end if;
1196       end loop Outer;
1197    end Find_Elab_Order;
1198
1199    -------------------------
1200    -- Gather_Dependencies --
1201    -------------------------
1202
1203    procedure Gather_Dependencies is
1204       Withed_Unit : Unit_Id;
1205
1206    begin
1207       --  Loop through all units
1208
1209       for U in Units.First .. Units.Last loop
1210          Cur_Unit := U;
1211
1212          --  If this is not an interface to a stand-alone library and
1213          --  there is a body and a spec, then spec must be elaborated first
1214          --  Note that the corresponding spec immediately follows the body
1215
1216          if not Units.Table (U).SAL_Interface
1217            and then Units.Table (U).Utype = Is_Body
1218          then
1219             Build_Link (Corresponding_Spec (U), U, Spec_First);
1220          end if;
1221
1222          --  If this unit is not an interface to a stand-alone library,
1223          --  process WITH references for this unit ignoring generic units and
1224          --  interfaces to stand-alone libraries.
1225
1226          if not Units.Table (U).SAL_Interface then
1227             for
1228               W in Units.Table (U).First_With .. Units.Table (U).Last_With
1229             loop
1230                if Withs.Table (W).Sfile /= No_File
1231                  and then (not Withs.Table (W).SAL_Interface)
1232                then
1233                   --  Check for special case of withing a unit that does not
1234                   --  exist any more. If the unit was completely missing we
1235                   --  would already have detected this, but a nasty case arises
1236                   --  when we have a subprogram body with no spec, and some
1237                   --  obsolete unit with's a previous (now disappeared) spec.
1238
1239                   if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then
1240                      Error_Msg_File_1 := Units.Table (U).Sfile;
1241                      Error_Msg_Unit_1 := Withs.Table (W).Uname;
1242                      Error_Msg ("{ depends on $ which no longer exists");
1243                      goto Next_With;
1244                   end if;
1245
1246                   Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname);
1247
1248                   --  Pragma Elaborate_All case, for this we use the recursive
1249                   --  Elab_All_Links procedure to establish the links.
1250
1251                   if Withs.Table (W).Elaborate_All then
1252
1253                      --  Reset flags used to stop multiple visits to a given
1254                      --  node.
1255
1256                      for Uref in UNR.First .. UNR.Last loop
1257                         UNR.Table (Uref).Visited := False;
1258                      end loop;
1259
1260                      --  Now establish all the links we need
1261
1262                      Elab_All_Links
1263                        (Withed_Unit, U, Elab_All,
1264                         Make_Elab_Entry
1265                           (Withs.Table (W).Uname, No_Elab_All_Link));
1266
1267                   --  Elaborate_All_Desirable case, for this we establish the
1268                   --  same links as above, but with a different reason.
1269
1270                   elsif Withs.Table (W).Elab_All_Desirable then
1271
1272                      --  Reset flags used to stop multiple visits to a given
1273                      --  node.
1274
1275                      for Uref in UNR.First .. UNR.Last loop
1276                         UNR.Table (Uref).Visited := False;
1277                      end loop;
1278
1279                      --  Now establish all the links we need
1280
1281                      Elab_All_Links
1282                        (Withed_Unit, U, Elab_All_Desirable,
1283                         Make_Elab_Entry
1284                           (Withs.Table (W).Uname, No_Elab_All_Link));
1285
1286                   --  Pragma Elaborate case. We must build a link for the
1287                   --  withed unit itself, and also the corresponding body if
1288                   --  there is one.
1289
1290                   --  However, skip this processing if there is no ALI file for
1291                   --  the WITH entry, because this means it is a generic (even
1292                   --  when we fix the generics so that an ALI file is present,
1293                   --  we probably still will have no ALI file for unchecked and
1294                   --  other special cases).
1295
1296                   elsif Withs.Table (W).Elaborate
1297                     and then Withs.Table (W).Afile /= No_File
1298                   then
1299                      Build_Link (Withed_Unit, U, Withed);
1300
1301                      if Units.Table (Withed_Unit).Utype = Is_Spec then
1302                         Build_Link
1303                           (Corresponding_Body (Withed_Unit), U, Elab);
1304                      end if;
1305
1306                   --  Elaborate_Desirable case, for this we establish
1307                   --  the same links as above, but with a different reason.
1308
1309                   elsif Withs.Table (W).Elab_Desirable then
1310                      Build_Link (Withed_Unit, U, Withed);
1311
1312                      if Units.Table (Withed_Unit).Utype = Is_Spec then
1313                         Build_Link
1314                           (Corresponding_Body (Withed_Unit),
1315                            U, Elab_Desirable);
1316                      end if;
1317
1318                   --  A limited_with does not establish an elaboration
1319                   --  dependence (that's the whole point!).
1320
1321                   elsif Withs.Table (W).Limited_With then
1322                      null;
1323
1324                   --  Case of normal WITH with no elaboration pragmas, just
1325                   --  build the single link to the directly referenced unit
1326
1327                   else
1328                      Build_Link (Withed_Unit, U, Withed);
1329                   end if;
1330                end if;
1331
1332                <<Next_With>>
1333                null;
1334             end loop;
1335          end if;
1336       end loop;
1337    end Gather_Dependencies;
1338
1339    ------------------
1340    -- Is_Body_Unit --
1341    ------------------
1342
1343    function Is_Body_Unit (U : Unit_Id) return Boolean is
1344    begin
1345       return Units.Table (U).Utype = Is_Body
1346         or else Units.Table (U).Utype = Is_Body_Only;
1347    end Is_Body_Unit;
1348
1349    -----------------------------
1350    -- Is_Pure_Or_Preelab_Unit --
1351    -----------------------------
1352
1353    function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean is
1354    begin
1355       --  If we have a body with separate spec, test flags on the spec
1356
1357       if Units.Table (U).Utype = Is_Body then
1358          return Units.Table (U + 1).Preelab
1359                   or else
1360                 Units.Table (U + 1).Pure;
1361
1362       --  Otherwise we have a spec or body acting as spec, test flags on unit
1363
1364       else
1365          return Units.Table (U).Preelab
1366                   or else
1367                 Units.Table (U).Pure;
1368       end if;
1369    end Is_Pure_Or_Preelab_Unit;
1370
1371    ---------------------
1372    -- Is_Waiting_Body --
1373    ---------------------
1374
1375    function Is_Waiting_Body (U : Unit_Id) return Boolean is
1376    begin
1377       return Units.Table (U).Utype = Is_Body
1378         and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
1379    end Is_Waiting_Body;
1380
1381    ---------------------
1382    -- Make_Elab_Entry --
1383    ---------------------
1384
1385    function Make_Elab_Entry
1386      (Unam : Unit_Name_Type;
1387       Link : Elab_All_Id) return Elab_All_Id
1388    is
1389    begin
1390       Elab_All_Entries.Increment_Last;
1391       Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam;
1392       Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link;
1393       return Elab_All_Entries.Last;
1394    end Make_Elab_Entry;
1395
1396    -------------------------------
1397    -- Pessimistic_Better_Choice --
1398    -------------------------------
1399
1400    function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean is
1401       UT1 : Unit_Record renames Units.Table (U1);
1402       UT2 : Unit_Record renames Units.Table (U2);
1403
1404    begin
1405       if Debug_Flag_B then
1406          Write_Str ("Pessimistic_Better_Choice (");
1407          Write_Unit_Name (UT1.Uname);
1408          Write_Str (", ");
1409          Write_Unit_Name (UT2.Uname);
1410          Write_Line (")");
1411       end if;
1412
1413       --  Note: the checks here are applied in sequence, and the ordering is
1414       --  significant (i.e. the more important criteria are applied first).
1415
1416       --  If either unit is predefined or internal, then we use the normal
1417       --  Better_Choice rule, since we don't want to disturb the elaboration
1418       --  rules of the language with -p, same treatment for Pure/Preelab.
1419
1420       --  Prefer a predefined unit to a non-predefined unit
1421
1422       if UT1.Predefined and then not UT2.Predefined then
1423          if Debug_Flag_B then
1424             Write_Line ("  True: u1 is predefined, u2 is not");
1425          end if;
1426
1427          return True;
1428
1429       elsif UT2.Predefined and then not UT1.Predefined then
1430          if Debug_Flag_B then
1431             Write_Line ("  False: u2 is predefined, u1 is not");
1432          end if;
1433
1434          return False;
1435
1436       --  Prefer an internal unit to a non-internal unit
1437
1438       elsif UT1.Internal and then not UT2.Internal then
1439          if Debug_Flag_B then
1440             Write_Line ("  True: u1 is internal, u2 is not");
1441          end if;
1442
1443          return True;
1444
1445       elsif UT2.Internal and then not UT1.Internal then
1446          if Debug_Flag_B then
1447             Write_Line ("  False: u2 is internal, u1 is not");
1448          end if;
1449
1450          return False;
1451
1452       --  Prefer a pure or preelaborable unit to one that is not
1453
1454       elsif Is_Pure_Or_Preelab_Unit (U1)
1455               and then not
1456             Is_Pure_Or_Preelab_Unit (U2)
1457       then
1458          if Debug_Flag_B then
1459             Write_Line ("  True: u1 is pure/preelab, u2 is not");
1460          end if;
1461
1462          return True;
1463
1464       elsif Is_Pure_Or_Preelab_Unit (U2)
1465               and then not
1466             Is_Pure_Or_Preelab_Unit (U1)
1467       then
1468          if Debug_Flag_B then
1469             Write_Line ("  False: u2 is pure/preelab, u1 is not");
1470          end if;
1471
1472          return False;
1473
1474       --  Prefer anything else to a waiting body. We want to make bodies wait
1475       --  as long as possible, till we are forced to choose them!
1476
1477       elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
1478          if Debug_Flag_B then
1479             Write_Line ("  False: u1 is waiting body, u2 is not");
1480          end if;
1481
1482          return False;
1483
1484       elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
1485          if Debug_Flag_B then
1486             Write_Line ("  True: u2 is waiting body, u1 is not");
1487          end if;
1488
1489          return True;
1490
1491       --  Prefer a spec to a body (!)
1492
1493       elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
1494          if Debug_Flag_B then
1495             Write_Line ("  False: u1 is body, u2 is not");
1496          end if;
1497
1498          return False;
1499
1500       elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
1501          if Debug_Flag_B then
1502             Write_Line ("  True: u2 is body, u1 is not");
1503          end if;
1504
1505          return True;
1506
1507       --  If both are waiting bodies, then prefer the one whose spec is
1508       --  less recently elaborated. Consider the following:
1509
1510       --     spec of A
1511       --     spec of B
1512       --     body of A or B?
1513
1514       --  The normal waiting body preference would have placed the body of
1515       --  A before the spec of B if it could. Since it could not, there it
1516       --  must be the case that A depends on B. It is therefore a good idea
1517       --  to put the body of B last so that if there is an elaboration order
1518       --  problem, we will find it (that's what pssimistic order is about)
1519
1520       elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
1521          declare
1522             Result : constant Boolean :=
1523                        UNR.Table (Corresponding_Spec (U1)).Elab_Position <
1524                        UNR.Table (Corresponding_Spec (U2)).Elab_Position;
1525          begin
1526             if Debug_Flag_B then
1527                if Result then
1528                   Write_Line ("  True: based on waiting body elab positions");
1529                else
1530                   Write_Line ("  False: based on waiting body elab positions");
1531                end if;
1532             end if;
1533
1534             return Result;
1535          end;
1536       end if;
1537
1538       --  Remaining choice rules are disabled by Debug flag -do
1539
1540       if not Debug_Flag_O then
1541
1542          --  The following deal with the case of specs which have been marked
1543          --  as Elaborate_Body_Desirable. In the normal case, we generally want
1544          --  to delay the elaboration of these specs as long as possible, so
1545          --  that bodies have better chance of being elaborated closer to the
1546          --  specs. Pessimistic_Better_Choice as usual wants to do the opposite
1547          --  and elaborate such specs as early as possible.
1548
1549          --  If we have two units, one of which is a spec for which this flag
1550          --  is set, and the other is not, we normally prefer to delay the spec
1551          --  for which the flag is set, so again Pessimistic_Better_Choice does
1552          --  the opposite.
1553
1554          if not UT1.Elaborate_Body_Desirable
1555            and then UT2.Elaborate_Body_Desirable
1556          then
1557             if Debug_Flag_B then
1558                Write_Line ("  False: u1 is elab body desirable, u2 is not");
1559             end if;
1560
1561             return False;
1562
1563          elsif not UT2.Elaborate_Body_Desirable
1564            and then UT1.Elaborate_Body_Desirable
1565          then
1566             if Debug_Flag_B then
1567                Write_Line ("  True: u1 is elab body desirable, u2 is not");
1568             end if;
1569
1570             return True;
1571
1572             --  If we have two specs that are both marked as Elaborate_Body
1573             --  desirable, we normally prefer the one whose body is nearer to
1574             --  being able to be elaborated, based on the Num_Pred count. This
1575             --  helps to ensure bodies are as close to specs as possible. As
1576             --  usual, Pessimistic_Better_Choice does the opposite.
1577
1578          elsif UT1.Elaborate_Body_Desirable
1579            and then UT2.Elaborate_Body_Desirable
1580          then
1581             declare
1582                Result : constant Boolean :=
1583                           UNR.Table (Corresponding_Body (U1)).Num_Pred >=
1584                           UNR.Table (Corresponding_Body (U2)).Num_Pred;
1585             begin
1586                if Debug_Flag_B then
1587                   if Result then
1588                      Write_Line ("  True based on Num_Pred compare");
1589                   else
1590                      Write_Line ("  False based on Num_Pred compare");
1591                   end if;
1592                end if;
1593
1594                return Result;
1595             end;
1596          end if;
1597       end if;
1598
1599       --  If we fall through, it means that no preference rule applies, so we
1600       --  use alphabetical order to at least give a deterministic result. Since
1601       --  Pessimistic_Better_Choice is in the business of stirring up the
1602       --  order, we will use reverse alphabetical ordering.
1603
1604       if Debug_Flag_B then
1605          Write_Line ("  choose on reverse alpha order");
1606       end if;
1607
1608       return Uname_Less (UT2.Uname, UT1.Uname);
1609    end Pessimistic_Better_Choice;
1610
1611    ----------------
1612    -- Unit_Id_Of --
1613    ----------------
1614
1615    function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
1616       Info : constant Int := Get_Name_Table_Info (Uname);
1617    begin
1618       pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
1619       return Unit_Id (Info);
1620    end Unit_Id_Of;
1621
1622    ------------------------
1623    -- Write_Dependencies --
1624    ------------------------
1625
1626    procedure Write_Dependencies is
1627    begin
1628       if not Zero_Formatting then
1629          Write_Eol;
1630          Write_Str ("                 ELABORATION ORDER DEPENDENCIES");
1631          Write_Eol;
1632          Write_Eol;
1633       end if;
1634
1635       Info_Prefix_Suppress := True;
1636
1637       for S in Succ_First .. Succ.Last loop
1638          Elab_Error_Msg (S);
1639       end loop;
1640
1641       Info_Prefix_Suppress := False;
1642
1643       if not Zero_Formatting then
1644          Write_Eol;
1645       end if;
1646    end Write_Dependencies;
1647
1648    --------------------------
1649    -- Write_Elab_All_Chain --
1650    --------------------------
1651
1652    procedure Write_Elab_All_Chain (S : Successor_Id) is
1653       ST     : constant Successor_Link := Succ.Table (S);
1654       After  : constant Unit_Name_Type := Units.Table (ST.After).Uname;
1655
1656       L   : Elab_All_Id;
1657       Nam : Unit_Name_Type;
1658
1659       First_Name : Boolean := True;
1660
1661    begin
1662       if ST.Reason in Elab_All .. Elab_All_Desirable then
1663          L := ST.Elab_All_Link;
1664          while L /= No_Elab_All_Link loop
1665             Nam := Elab_All_Entries.Table (L).Needed_By;
1666             Error_Msg_Unit_1 := Nam;
1667             Error_Msg_Output ("        $", Info => True);
1668
1669             Get_Name_String (Nam);
1670
1671             if Name_Buffer (Name_Len) = 'b' then
1672                if First_Name then
1673                   Error_Msg_Output
1674                     ("           must be elaborated along with its spec:",
1675                      Info => True);
1676
1677                else
1678                   Error_Msg_Output
1679                     ("           which must be elaborated " &
1680                      "along with its spec:",
1681                      Info => True);
1682                end if;
1683
1684             else
1685                if First_Name then
1686                   Error_Msg_Output
1687                     ("           is withed by:",
1688                      Info => True);
1689
1690                else
1691                   Error_Msg_Output
1692                     ("           which is withed by:",
1693                      Info => True);
1694                end if;
1695             end if;
1696
1697             First_Name := False;
1698
1699             L := Elab_All_Entries.Table (L).Next_Elab;
1700          end loop;
1701
1702          Error_Msg_Unit_1 := After;
1703          Error_Msg_Output ("        $", Info => True);
1704       end if;
1705    end Write_Elab_All_Chain;
1706
1707 end Binde;