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