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 --                                                                          --
  10 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- GNAT was originally developed  by the GNAT team at  New York University. --
  24 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  25 --                                                                          --
  26 ------------------------------------------------------------------------------
  27
  28 with Binderr; use Binderr;
  29 with Butil;   use Butil;
  30 with Debug;   use Debug;
  31 with Fname;   use Fname;
  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 no ALI file for this with, happens with certain
 770          --  specialized generic files that do not get compiled.
 771
 772          if Withs.Table (W).Afile /= No_File then
 773
 774             Elab_All_Links
 775               (Unit_Id_Of (Withs.Table (W).Uname),
 776                After,
 777                Reason,
 778                Make_Elab_Entry (Withs.Table (W).Uname, Link));
 779          end if;
 780       end loop;
 781
 782       --  Process corresponding body, if there is one
 783
 784       if Units.Table (Before).Utype = Is_Spec then
 785          Elab_All_Links
 786            (Corresponding_Body (Before),
 787             After, Reason,
 788             Make_Elab_Entry
 789               (Units.Table (Corresponding_Body (Before)).Uname, Link));
 790       end if;
 791    end Elab_All_Links;
 792
 793    --------------------
 794    -- Elab_Error_Msg --
 795    --------------------
 796
 797    procedure Elab_Error_Msg (S : Successor_Id) is
 798       SL : Successor_Link renames Succ.Table (S);
 799
 800    begin
 801       --  Nothing to do if internal unit involved and no -de flag
 802
 803       if not Debug_Flag_E
 804         and then
 805           (Is_Internal_File_Name (Units.Table (SL.Before).Sfile)
 806             or else
 807            Is_Internal_File_Name (Units.Table (SL.After).Sfile))
 808       then
 809          return;
 810       end if;
 811
 812       --  Here we want to generate output
 813
 814       Error_Msg_Name_1 := Units.Table (SL.Before).Uname;
 815
 816       if SL.Elab_Body then
 817          Error_Msg_Name_2 := Units.Table (Corresponding_Body (SL.After)).Uname;
 818       else
 819          Error_Msg_Name_2 := Units.Table (SL.After).Uname;
 820       end if;
 821
 822       Error_Msg_Output ("  & must be elaborated before &", Info => True);
 823
 824       Error_Msg_Name_1 := Units.Table (SL.Reason_Unit).Uname;
 825
 826       case SL.Reason is
 827          when Withed =>
 828             Error_Msg_Output
 829               ("     reason: with clause",
 830                Info => True);
 831
 832          when Elab =>
 833             Error_Msg_Output
 834               ("     reason: pragma Elaborate in unit &",
 835                Info => True);
 836
 837          when Elab_All =>
 838             Error_Msg_Output
 839               ("     reason: pragma Elaborate_All in unit &",
 840                Info => True);
 841
 842          when Elab_Desirable =>
 843             Error_Msg_Output
 844               ("     reason: Elaborate_All probably needed in unit &",
 845                Info => True);
 846
 847             Error_Msg_Output
 848               ("     recompile & with -gnatwl for full details",
 849                Info => True);
 850
 851          when Spec_First =>
 852             Error_Msg_Output
 853               ("     reason: spec always elaborated before body",
 854                Info => True);
 855       end case;
 856
 857       Write_Elab_All_Chain (S);
 858
 859       if SL.Elab_Body then
 860          Error_Msg_Name_1 := Units.Table (SL.Before).Uname;
 861          Error_Msg_Name_2 := Units.Table (SL.After).Uname;
 862          Error_Msg_Output
 863            ("  & must therefore be elaborated before &",
 864             True);
 865
 866          Error_Msg_Name_1 := Units.Table (SL.After).Uname;
 867          Error_Msg_Output
 868            ("     (because & has a pragma Elaborate_Body)",
 869             True);
 870       end if;
 871
 872       Write_Eol;
 873    end Elab_Error_Msg;
 874
 875    ---------------------
 876    -- Find_Elab_Order --
 877    ---------------------
 878
 879    procedure Find_Elab_Order is
 880       U           : Unit_Id;
 881       Best_So_Far : Unit_Id;
 882
 883    begin
 884       Succ.Init;
 885       Num_Left := Int (Units.Last - Units.First + 1);
 886
 887       --  Initialize unit table for elaboration control
 888
 889       for U in Units.First .. Units.Last loop
 890          UNR.Increment_Last;
 891          UNR.Table (UNR.Last).Successors    := No_Successor;
 892          UNR.Table (UNR.Last).Num_Pred      := 0;
 893          UNR.Table (UNR.Last).Nextnp        := No_Unit_Id;
 894          UNR.Table (UNR.Last).Elab_Order    := 0;
 895          UNR.Table (UNR.Last).Elab_Position := 0;
 896       end loop;
 897
 898       --  Gather dependencies and output them if option set
 899
 900       Gather_Dependencies;
 901
 902       --  Output elaboration dependencies if option is set
 903
 904       if Elab_Dependency_Output or Debug_Flag_E then
 905          Write_Dependencies;
 906       end if;
 907
 908       --  Initialize the no predecessor list
 909
 910       No_Pred := No_Unit_Id;
 911
 912       for U in UNR.First .. UNR.Last loop
 913          if UNR.Table (U).Num_Pred = 0 then
 914             UNR.Table (U).Nextnp := No_Pred;
 915             No_Pred := U;
 916          end if;
 917       end loop;
 918
 919       --  OK, now we determine the elaboration order proper. All we do is to
 920       --  select the best choice from the no predecessor list until all the
 921       --  nodes have been chosen.
 922
 923       Outer : loop
 924          --  If there are no nodes with predecessors, then either we are
 925          --  done, as indicated by Num_Left being set to zero, or we have
 926          --  a circularity. In the latter case, diagnose the circularity,
 927          --  removing it from the graph and continue
 928
 929          Get_No_Pred : while No_Pred = No_Unit_Id loop
 930             exit Outer when Num_Left < 1;
 931             Diagnose_Elaboration_Problem;
 932          end loop Get_No_Pred;
 933
 934          U := No_Pred;
 935          Best_So_Far := No_Unit_Id;
 936
 937          --  Loop to choose best entry in No_Pred list
 938
 939          No_Pred_Search : loop
 940             if Debug_Flag_N then
 941                Write_Str ("  considering choice of ");
 942                Write_Unit_Name (Units.Table (U).Uname);
 943                Write_Eol;
 944
 945                if Units.Table (U).Elaborate_Body then
 946                   Write_Str
 947                     ("    Elaborate_Body = True, Num_Pred for body = ");
 948                   Write_Int
 949                     (Int (UNR.Table (Corresponding_Body (U)).Num_Pred));
 950                else
 951                   Write_Str
 952                     ("    Elaborate_Body = False");
 953                end if;
 954
 955                Write_Eol;
 956             end if;
 957
 958             --  This is a candididate to be considered for choice
 959
 960             if Best_So_Far = No_Unit_Id
 961               or else ((not Pessimistic_Elab_Order)
 962                          and then Better_Choice (U, Best_So_Far))
 963               or else (Pessimistic_Elab_Order
 964                          and then Worse_Choice (U, Best_So_Far))
 965             then
 966                if Debug_Flag_N then
 967                   Write_Str ("    tentatively chosen (best so far)");
 968                   Write_Eol;
 969                end if;
 970
 971                Best_So_Far := U;
 972             end if;
 973
 974             U := UNR.Table (U).Nextnp;
 975             exit No_Pred_Search when U = No_Unit_Id;
 976          end loop No_Pred_Search;
 977
 978          --  If no candididate chosen, it means that no unit has No_Pred = 0,
 979          --  but there are units left, hence we have a circular dependency,
 980          --  which we will get Diagnose_Elaboration_Problem to diagnose it.
 981
 982          if Best_So_Far = No_Unit_Id then
 983             Diagnose_Elaboration_Problem;
 984
 985          --  Otherwise choose the best candidate found
 986
 987          else
 988             Choose (Best_So_Far);
 989          end if;
 990       end loop Outer;
 991
 992    end Find_Elab_Order;
 993
 994    -------------------------
 995    -- Gather_Dependencies --
 996    -------------------------
 997
 998    procedure Gather_Dependencies is
 999       Withed_Unit : Unit_Id;
1000
1001    begin
1002       --  Loop through all units
1003
1004       for U in Units.First .. Units.Last loop
1005          Cur_Unit := U;
1006
1007          --  If there is a body and a spec, then spec must be elaborated first
1008          --  Note that the corresponding spec immediately follows the body
1009
1010          if Units.Table (U).Utype = Is_Body then
1011             Build_Link (Corresponding_Spec (U), U, Spec_First);
1012          end if;
1013
1014          --  Process WITH references for this unit ignoring generic units
1015
1016          for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop
1017             if Withs.Table (W).Sfile /= No_File then
1018
1019                --  Check for special case of withing a unit that does not
1020                --  exist any more. If the unit was completely missing we would
1021                --  already have detected this, but a nasty case arises when we
1022                --  have a subprogram body with no spec, and some obsolete unit
1023                --  with's a previous (now disappeared) spec.
1024
1025                if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then
1026                   Error_Msg_Name_1 := Units.Table (U).Sfile;
1027                   Error_Msg_Name_2 := Withs.Table (W).Uname;
1028                   Error_Msg ("% depends on & which no longer exists");
1029                   goto Next_With;
1030                end if;
1031
1032                Withed_Unit :=
1033                  Unit_Id (Unit_Id_Of (Withs.Table (W).Uname));
1034
1035                --  Pragma Elaborate_All case, for this we use the recursive
1036                --  Elab_All_Links procedure to establish the links.
1037
1038                if Withs.Table (W).Elaborate_All then
1039
1040                   --  Reset flags used to stop multiple visits to a given node
1041
1042                   for Uref in UNR.First .. UNR.Last loop
1043                      UNR.Table (Uref).Visited := False;
1044                   end loop;
1045
1046                   --  Now establish all the links we need
1047
1048                   Elab_All_Links
1049                     (Withed_Unit, U, Elab_All,
1050                      Make_Elab_Entry
1051                        (Withs.Table (W).Uname, No_Elab_All_Link));
1052
1053                --  Elaborate_All_Desirable case, for this we establish the
1054                --  same links as above, but with a different reason.
1055
1056                elsif Withs.Table (W).Elab_All_Desirable then
1057
1058                   --  Reset flags used to stop multiple visits to a given node
1059
1060                   for Uref in UNR.First .. UNR.Last loop
1061                      UNR.Table (Uref).Visited := False;
1062                   end loop;
1063
1064                   --  Now establish all the links we need
1065
1066                   Elab_All_Links
1067                     (Withed_Unit, U, Elab_Desirable,
1068                      Make_Elab_Entry
1069                        (Withs.Table (W).Uname, No_Elab_All_Link));
1070
1071                --  Pragma Elaborate case. We must build a link for the withed
1072                --  unit itself, and also the corresponding body if there is one
1073
1074                --  However, skip this processing if there is no ALI file for
1075                --  the WITH entry, because this means it is a generic (even
1076                --  when we fix the generics so that an ALI file is present,
1077                --  we probably still will have no ALI file for unchecked
1078                --  and other special cases).
1079
1080                elsif Withs.Table (W).Elaborate
1081                  and then Withs.Table (W).Afile /= No_File
1082                then
1083                   Build_Link (Withed_Unit, U, Withed);
1084
1085                   if Units.Table (Withed_Unit).Utype = Is_Spec then
1086                      Build_Link
1087                       (Corresponding_Body (Withed_Unit), U, Elab);
1088                   end if;
1089
1090                --  Case of normal WITH with no elaboration pragmas, just
1091                --  build the single link to the directly referenced unit
1092
1093                else
1094                   Build_Link (Withed_Unit, U, Withed);
1095                end if;
1096             end if;
1097
1098             <<Next_With>>
1099                null;
1100          end loop;
1101       end loop;
1102    end Gather_Dependencies;
1103
1104    ---------------------
1105    -- Make_Elab_Entry --
1106    ---------------------
1107
1108    function Make_Elab_Entry
1109      (Unam : Unit_Name_Type;
1110       Link : Elab_All_Id)
1111       return Elab_All_Id
1112    is
1113    begin
1114       Elab_All_Entries.Increment_Last;
1115       Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam;
1116       Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link;
1117       return Elab_All_Entries.Last;
1118    end Make_Elab_Entry;
1119
1120    ----------------
1121    -- Unit_Id_Of --
1122    ----------------
1123
1124    function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
1125       Info : constant Int := Get_Name_Table_Info (Uname);
1126
1127    begin
1128       pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
1129       return Unit_Id (Info);
1130    end Unit_Id_Of;
1131
1132    ------------------
1133    -- Worse_Choice --
1134    ------------------
1135
1136    function Worse_Choice (U1, U2 : Unit_Id) return Boolean is
1137
1138       function Body_Unit (U : Unit_Id) return Boolean;
1139       --  Determines if given unit is a body
1140
1141       function Waiting_Body (U : Unit_Id) return Boolean;
1142       --  Determines if U is a waiting body, defined as a body which has
1143       --  not been elaborated, but whose spec has been elaborated.
1144
1145       function Body_Unit (U : Unit_Id) return Boolean is
1146       begin
1147          return Units.Table (U).Utype = Is_Body
1148            or else Units.Table (U).Utype = Is_Body_Only;
1149       end Body_Unit;
1150
1151       function Waiting_Body (U : Unit_Id) return Boolean is
1152       begin
1153          return Units.Table (U).Utype = Is_Body and then
1154             UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
1155       end Waiting_Body;
1156
1157    --  Start of processing for Worse_Choice
1158
1159    --  Note: the checks here are applied in sequence, and the ordering is
1160    --  significant (i.e. the more important criteria are applied first).
1161
1162    begin
1163       --  If either unit is internal, then use Better_Choice, since the
1164       --  language requires that predefined units not mess up in the choice
1165       --  of elaboration order, and for internal units, any problems are
1166       --  ours and not the programmers.
1167
1168       if Units.Table (U1).Internal or else Units.Table (U2).Internal then
1169          return Better_Choice (U1, U2);
1170
1171       --  Prefer anything else to a waiting body (!)
1172
1173       elsif Waiting_Body (U1) and not Waiting_Body (U2) then
1174          return False;
1175
1176       elsif Waiting_Body (U2) and not Waiting_Body (U1) then
1177          return True;
1178
1179       --  Prefer a spec to a body (!)
1180
1181       elsif Body_Unit (U1) and not Body_Unit (U2) then
1182          return False;
1183
1184       elsif Body_Unit (U2) and not Body_Unit (U1) then
1185          return True;
1186
1187       --  If both are waiting bodies, then prefer the one whose spec is
1188       --  less recently elaborated. Consider the following:
1189
1190       --     spec of A
1191       --     spec of B
1192       --     body of A or B?
1193
1194       --  The normal waiting body preference would have placed the body of
1195       --  A before the spec of B if it could. Since it could not, there it
1196       --  must be the case that A depends on B. It is therefore a good idea
1197       --  to put the body of B last so that if there is an elaboration order
1198       --  problem, we will find it (that's what horrible order is about)
1199
1200       elsif Waiting_Body (U1) and then Waiting_Body (U2) then
1201          return
1202            UNR.Table (Corresponding_Spec (U1)).Elab_Position <
1203            UNR.Table (Corresponding_Spec (U2)).Elab_Position;
1204
1205       --  Otherwise decide on the basis of alphabetical order. We do not try
1206       --  to reverse the usual choice here, since it can cause cancelling
1207       --  errors with the other inversions.
1208
1209       else
1210          return Uname_Less (Units.Table (U1).Uname, Units.Table (U2).Uname);
1211       end if;
1212    end Worse_Choice;
1213
1214    ------------------------
1215    -- Write_Dependencies --
1216    ------------------------
1217
1218    procedure Write_Dependencies is
1219    begin
1220       Write_Eol;
1221       Write_Str
1222         ("                 ELABORATION ORDER DEPENDENCIES");
1223       Write_Eol;
1224       Write_Eol;
1225
1226       Info_Prefix_Suppress := True;
1227
1228       for S in Succ_First .. Succ.Last loop
1229          Elab_Error_Msg (S);
1230       end loop;
1231
1232       Info_Prefix_Suppress := False;
1233       Write_Eol;
1234    end Write_Dependencies;
1235
1236    --------------------------
1237    -- Write_Elab_All_Chain --
1238    --------------------------
1239
1240    procedure Write_Elab_All_Chain (S : Successor_Id) is
1241       ST     : constant Successor_Link := Succ.Table (S);
1242       After  : constant Unit_Name_Type := Units.Table (ST.After).Uname;
1243
1244       L   : Elab_All_Id;
1245       Nam : Unit_Name_Type;
1246
1247       First_Name : Boolean := True;
1248
1249    begin
1250       if ST.Reason in Elab_All .. Elab_Desirable then
1251          L := ST.Elab_All_Link;
1252          while L /= No_Elab_All_Link loop
1253             Nam := Elab_All_Entries.Table (L).Needed_By;
1254             Error_Msg_Name_1 := Nam;
1255             Error_Msg_Output ("        &", Info => True);
1256
1257             Get_Name_String (Nam);
1258
1259             if Name_Buffer (Name_Len) = 'b' then
1260                if First_Name then
1261                   Error_Msg_Output
1262                     ("           must be elaborated along with its spec:",
1263                      Info => True);
1264
1265                else
1266                   Error_Msg_Output
1267                     ("           which must be elaborated " &
1268                      "along with its spec:",
1269                      Info => True);
1270                end if;
1271
1272             else
1273                if First_Name then
1274                   Error_Msg_Output
1275                     ("           is withed by:",
1276                      Info => True);
1277
1278                else
1279                   Error_Msg_Output
1280                     ("           which is withed by:",
1281                      Info => True);
1282                end if;
1283             end if;
1284
1285             First_Name := False;
1286
1287             L := Elab_All_Entries.Table (L).Next_Elab;
1288          end loop;
1289
1290          Error_Msg_Name_1 := After;
1291          Error_Msg_Output ("        &", Info => True);
1292       end if;
1293    end Write_Elab_All_Chain;
1294
1295 end Binde;