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