gcc/ada/binde.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                B I N D E                                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2005 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Binderr;  use Binderr;
  28 with Butil;    use Butil;
  29 with Debug;    use Debug;
  30 with Fname;    use Fname;
  31 with Lib;      use Lib;
  32 with Namet;    use Namet;
  33 with Opt;      use Opt;
  34 with Output;   use Output;
  35 with Targparm; use Targparm;
  36
  37 package body Binde is
  38
  39    --  The following data structures are used to represent the graph that is
  40    --  used to determine the elaboration order (using a topological sort).
  41
  42    --  The following structures are used to record successors. If A is a
  43    --  successor of B in this table, it means that A must be elaborated
  44    --  before B is elaborated.
  45
  46    type Successor_Id is new Nat;
  47    --  Identification of single successor entry
  48
  49    No_Successor : constant Successor_Id := 0;
  50    --  Used to indicate end of list of successors
  51
  52    type Elab_All_Id is new Nat;
  53    --  Identification of Elab_All entry link
  54
  55    No_Elab_All_Link : constant Elab_All_Id := 0;
  56    --  Used to indicate end of list
  57
  58    --  Succ_Reason indicates the reason for a particular elaboration link
  59
  60    type Succ_Reason is
  61      (Withed,
  62       --  After directly with's Before, so the spec of Before must be
  63       --  elaborated before After is elaborated.
  64
  65       Elab,
  66       --  After directly mentions Before in a pragma Elaborate, so the
  67       --  body of Before must be elaborate before After is elaborated.
  68
  69       Elab_All,
  70       --  After either mentions Before directly in a pragma Elaborate_All,
  71       --  or mentions a third unit, X, which itself requires that Before be
  72       --  elaborated before unit X is elaborated. The Elab_All_Link list
  73       --  traces the dependencies in the latter case.
  74
  75       Elab_Desirable,
  76       --  This is just like Elab_All, except that the elaborate all was not
  77       --  explicitly present in the source, but rather was created by the
  78       --  front end, which decided that it was "desirable".
  79
  80       Spec_First);
  81       --  After is a body, and Before is the corresponding spec
  82
  83    --  Successor_Link contains the information for one link
  84
  85    type Successor_Link is record
  86       Before : Unit_Id;
  87       --  Predecessor unit
  88
  89       After : Unit_Id;
  90       --  Successor unit
  91
  92       Next : Successor_Id;
  93       --  Next successor on this list
  94
  95       Reason : Succ_Reason;
  96       --  Reason for this link
  97
  98       Elab_Body : Boolean;
  99       --  Set True if this link is needed for the special Elaborate_Body
 100       --  processing described below.
 101
 102       Reason_Unit : Unit_Id;
 103       --  For Reason = Elab, or Elab_All or Elab_Desirable, records the unit
 104       --  containing the pragma leading to the link.
 105
 106       Elab_All_Link : Elab_All_Id;
 107       --  If Reason = Elab_All or Elab_Desirable, then this points to the
 108       --  first elment in a list of Elab_All entries that record the with
 109       --  chain leading resulting in this particular dependency.
 110
 111    end record;
 112
 113    --  Note on handling of Elaborate_Body. Basically, if we have a pragma
 114    --  Elaborate_Body in a unit, it means that the spec and body have to
 115    --  be handled as a single entity from the point of view of determining
 116    --  an elaboration order. What we do is to essentially remove the body
 117    --  from consideration completely, and transfer all its links (other
 118    --  than the spec link) to the spec. Then when then the spec gets chosen,
 119    --  we choose the body right afterwards. We mark the links that get moved
 120    --  from the body to the spec by setting their Elab_Body flag True, so
 121    --  that we can understand what is going on!
 122
 123    Succ_First : constant := 1;
 124
 125    package Succ is new Table.Table (
 126      Table_Component_Type => Successor_Link,
 127      Table_Index_Type     => Successor_Id,
 128      Table_Low_Bound      => Succ_First,
 129      Table_Initial        => 500,
 130      Table_Increment      => 200,
 131      Table_Name           => "Succ");
 132
 133    --  For the case of Elaborate_All, the following table is used to record
 134    --  chains of with relationships that lead to the Elab_All link. These
 135    --  are used solely for diagnostic purposes
 136
 137    type Elab_All_Entry is record
 138       Needed_By : Unit_Name_Type;
 139       --  Name of unit from which referencing unit was with'ed or otherwise
 140       --  needed as a result of Elaborate_All or Elaborate_Desirable.
 141
 142       Next_Elab : Elab_All_Id;
 143       --  Link to next entry on chain (No_Elab_All_Link marks end of list)
 144    end record;
 145
 146    package Elab_All_Entries is new Table.Table (
 147      Table_Component_Type => Elab_All_Entry,
 148      Table_Index_Type     => Elab_All_Id,
 149      Table_Low_Bound      => 1,
 150      Table_Initial        => 2000,
 151      Table_Increment      => 200,
 152      Table_Name           => "Elab_All_Entries");
 153
 154    --  A Unit_Node record is built for each active unit
 155
 156    type Unit_Node_Record is record
 157
 158       Successors : Successor_Id;
 159       --  Pointer to list of links for successor nodes
 160
 161       Num_Pred : Int;
 162       --  Number of predecessors for this unit. Normally non-negative, but
 163       --  can go negative in the case of units chosen by the diagnose error
 164       --  procedure (when cycles are being removed from the graph).
 165
 166       Nextnp : Unit_Id;
 167       --  Forward pointer for list of units with no predecessors
 168
 169       Elab_Order : Nat;
 170       --  Position in elaboration order (zero = not placed yet)
 171
 172       Visited : Boolean;
 173       --  Used in computing transitive closure for elaborate all and
 174       --  also in locating cycles and paths in the diagnose routines.
 175
 176       Elab_Position : Natural;
 177       --  Initialized to zero. Set non-zero when a unit is chosen and
 178       --  placed in the elaboration order. The value represents the
 179       --  ordinal position in the elaboration order.
 180
 181    end record;
 182
 183    package UNR is new Table.Table (
 184      Table_Component_Type => Unit_Node_Record,
 185      Table_Index_Type     => Unit_Id,
 186      Table_Low_Bound      => First_Unit_Entry,
 187      Table_Initial        => 500,
 188      Table_Increment      => 200,
 189      Table_Name           => "UNR");
 190
 191    No_Pred : Unit_Id;
 192    --  Head of list of items with no predecessors
 193
 194    Num_Left : Int;
 195    --  Number of entries not yet dealt with
 196
 197    Cur_Unit : Unit_Id;
 198    --  Current unit, set by Gather_Dependencies, and picked up in Build_Link
 199    --  to set the Reason_Unit field of the created dependency link.
 200
 201    Num_Chosen : Natural := 0;
 202    --  Number of units chosen in the elaboration order so far
 203
 204    -----------------------
 205    -- Local Subprograms --
 206    -----------------------
 207
 208    function Better_Choice (U1, U2 : Unit_Id) return Boolean;
 209    --  U1 and U2 are both permitted candidates for selection as the next unit
 210    --  to be elaborated. This function determines whether U1 is a better choice
 211    --  than U2, i.e. should be elaborated in preference to U2, based on a set
 212    --  of heuristics that establish a friendly and predictable order (see body
 213    --  for details). The result is True if U1 is a better choice than U2, and
 214    --  False if it is a worse choice, or there is no preference between them.
 215
 216    procedure Build_Link
 217      (Before : Unit_Id;
 218       After  : Unit_Id;
 219       R      : Succ_Reason;
 220       Ea_Id  : Elab_All_Id := No_Elab_All_Link);
 221    --  Establish a successor link, Before must be elaborated before After,
 222    --  and the reason for the link is R. Ea_Id is the contents to be placed
 223    --  in the Elab_All_Link of the entry.
 224
 225    procedure Choose (Chosen : Unit_Id);
 226    --  Chosen is the next entry chosen in the elaboration order. This
 227    --  procedure updates all data structures appropriately.
 228
 229    function Corresponding_Body (U : Unit_Id) return Unit_Id;
 230    pragma Inline (Corresponding_Body);
 231    --  Given a unit which is a spec for which there is a separate body,
 232    --  return the unit id of the body. It is an error to call this routine
 233    --  with a unit that is not a spec, or which does not have a separate body.
 234
 235    function Corresponding_Spec (U : Unit_Id) return Unit_Id;
 236    pragma Inline (Corresponding_Spec);
 237    --  Given a unit which is a body for which there is a separate spec,
 238    --  return the unit id of the spec. It is an error to call this routine
 239    --  with a unit that is not a body, or which does not have a separate spec.
 240
 241    procedure Diagnose_Elaboration_Problem;
 242    --  Called when no elaboration order can be found. Outputs an appropriate
 243    --  diagnosis of the problem, and then abandons the bind.
 244
 245    procedure Elab_All_Links
 246      (Before : Unit_Id;
 247       After  : Unit_Id;
 248       Reason : Succ_Reason;
 249       Link   : Elab_All_Id);
 250    --  Used to compute the transitive closure of elaboration links for an
 251    --  Elaborate_All pragma (Reason = Elab_All) or for an indication of
 252    --  Elaborate_All_Desirable (Reason = Elab_Desirable). Unit After has
 253    --  a pragma Elaborate_All or the front end has determined that a reference
 254    --  probably requires Elaborate_All is required, and unit Before must be
 255    --  previously elaborated. First a link is built making sure that unit
 256    --  Before is elaborated before After, then a recursive call ensures that
 257    --  we also build links for any units needed by Before (i.e. these units
 258    --  must/should also be elaborated before After). Link is used to build
 259    --  a chain of Elab_All_Entries to explain the reason for a link. The
 260    --  value passed is the chain so far.
 261
 262    procedure Elab_Error_Msg (S : Successor_Id);
 263    --  Given a successor link, outputs an error message of the form
 264    --  "& must be elaborated before & ..." where ... is the reason.
 265
 266    procedure Gather_Dependencies;
 267    --  Compute dependencies, building the Succ and UNR tables
 268
 269    function Make_Elab_Entry
 270      (Unam : Unit_Name_Type;
 271       Link : Elab_All_Id)
 272       return Elab_All_Id;
 273    --  Make an Elab_All_Entries table entry with the given Unam and Link
 274
 275    function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id;
 276    --  This function uses the Info field set in the names table to obtain
 277    --  the unit Id of a unit, given its name id value.
 278
 279    function Worse_Choice (U1, U2 : Unit_Id) return Boolean;
 280    --  This is like Better_Choice, and has the same interface, but returns
 281    --  true if U1 is a worse choice than U2 in the sense of the -h (horrible
 282    --  elaboration order) switch. We still have to obey Ada rules, so it is
 283    --  not quite the direct inverse of Better_Choice.
 284
 285    procedure Write_Dependencies;
 286    --  Write out dependencies (called only if appropriate option is set)
 287
 288    procedure Write_Elab_All_Chain (S : Successor_Id);
 289    --  If the reason for the link S is Elaborate_All or Elaborate_Desirable,
 290    --  then this routine will output the "needed by" explanation chain.
 291
 292    -------------------
 293    -- Better_Choice --
 294    -------------------
 295
 296    function Better_Choice (U1, U2 : Unit_Id) return Boolean is
 297
 298       function Body_Unit (U : Unit_Id) return Boolean;
 299       --  Determines if given unit is a body
 300
 301       function Waiting_Body (U : Unit_Id) return Boolean;
 302       --  Determines if U is a waiting body, defined as a body which has
 303       --  not been elaborated, but whose spec has been elaborated.
 304
 305       function Body_Unit (U : Unit_Id) return Boolean is
 306       begin
 307          return Units.Table (U).Utype = Is_Body
 308            or else Units.Table (U).Utype = Is_Body_Only;
 309       end Body_Unit;
 310
 311       function Waiting_Body (U : Unit_Id) return Boolean is
 312       begin
 313          return Units.Table (U).Utype = Is_Body
 314            and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
 315       end Waiting_Body;
 316
 317    --  Start of processing for Better_Choice
 318
 319    --  Note: the checks here are applied in sequence, and the ordering is
 320    --  significant (i.e. the more important criteria are applied first).
 321
 322    begin
 323       --  Prefer a waiting body to any other case
 324
 325       if Waiting_Body (U1) and not Waiting_Body (U2) then
 326          return True;
 327
 328       elsif Waiting_Body (U2) and not Waiting_Body (U1) then
 329          return False;
 330
 331       --  Prefer a predefined unit to a non-predefined unit
 332
 333       elsif Units.Table (U1).Predefined
 334         and not Units.Table (U2).Predefined
 335       then
 336          return True;
 337
 338       elsif Units.Table (U2).Predefined
 339         and not Units.Table (U1).Predefined
 340       then
 341          return False;
 342
 343       --  Prefer an internal unit to a non-internal unit
 344
 345       elsif Units.Table (U1).Internal
 346         and not Units.Table (U2).Internal
 347       then
 348          return True;
 349
 350       elsif Units.Table (U2).Internal
 351         and not Units.Table (U1).Internal
 352       then
 353          return False;
 354
 355       --  Prefer a body to a spec
 356
 357       elsif Body_Unit (U1) and not Body_Unit (U2) then
 358          return True;
 359
 360       elsif Body_Unit (U2) and not Body_Unit (U1) then
 361          return False;
 362
 363       --  If both are waiting bodies, then prefer the one whose spec is
 364       --  more recently elaborated. Consider the following:
 365
 366       --     spec of A
 367       --     spec of B
 368       --     body of A or B?
 369
 370       --  The normal waiting body preference would have placed the body of
 371       --  A before the spec of B if it could. Since it could not, there it
 372       --  must be the case that A depends on B. It is therefore a good idea
 373       --  to put the body of B first.
 374
 375       elsif Waiting_Body (U1) and then Waiting_Body (U2) then
 376          return
 377            UNR.Table (Corresponding_Spec (U1)).Elab_Position >
 378            UNR.Table (Corresponding_Spec (U2)).Elab_Position;
 379
 380       --  Otherwise decide on the basis of alphabetical order
 381
 382       else
 383          return Uname_Less (Units.Table (U1).Uname, Units.Table (U2).Uname);
 384       end if;
 385    end Better_Choice;
 386
 387    ----------------
 388    -- Build_Link --
 389    ----------------
 390
 391    procedure Build_Link
 392      (Before : Unit_Id;
 393       After  : Unit_Id;
 394       R      : Succ_Reason;
 395       Ea_Id  : Elab_All_Id := No_Elab_All_Link)
 396    is
 397       Cspec : Unit_Id;
 398
 399    begin
 400       Succ.Increment_Last;
 401       Succ.Table (Succ.Last).Before          := Before;
 402       Succ.Table (Succ.Last).Next            := UNR.Table (Before).Successors;
 403       UNR.Table (Before).Successors          := Succ.Last;
 404       Succ.Table (Succ.Last).Reason          := R;
 405       Succ.Table (Succ.Last).Reason_Unit     := Cur_Unit;
 406       Succ.Table (Succ.Last).Elab_All_Link   := Ea_Id;
 407
 408       --  Deal with special Elab_Body case. If the After of this link is
 409       --  a body whose spec has Elaborate_All set, and this is not the link
 410       --  directly from the body to the spec, then we make the After of the
 411       --  link reference its spec instead, marking the link appropriately.
 412
 413       if Units.Table (After).Utype = Is_Body then
 414          Cspec := Corresponding_Spec (After);
 415
 416          if Units.Table (Cspec).Elaborate_Body
 417            and then Cspec /= Before
 418          then
 419             Succ.Table (Succ.Last).After     := Cspec;
 420             Succ.Table (Succ.Last).Elab_Body := True;
 421             UNR.Table (Cspec).Num_Pred       := UNR.Table (Cspec).Num_Pred + 1;
 422             return;
 423          end if;
 424       end if;
 425
 426       --  Fall through on normal case
 427
 428       Succ.Table (Succ.Last).After           := After;
 429       Succ.Table (Succ.Last).Elab_Body       := False;
 430       UNR.Table (After).Num_Pred             := UNR.Table (After).Num_Pred + 1;
 431    end Build_Link;
 432
 433    ------------
 434    -- Choose --
 435    ------------
 436
 437    procedure Choose (Chosen : Unit_Id) is
 438       S : Successor_Id;
 439       U : Unit_Id;
 440
 441    begin
 442       if Debug_Flag_C then
 443          Write_Str ("Choosing Unit ");
 444          Write_Unit_Name (Units.Table (Chosen).Uname);
 445          Write_Eol;
 446       end if;
 447
 448       --  Add to elaboration order. Note that units having no elaboration
 449       --  code are not treated specially yet. The special casing of this
 450       --  is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile
 451       --  we need them here, because the object file list is also driven
 452       --  by the contents of the Elab_Order table.
 453
 454       Elab_Order.Increment_Last;
 455       Elab_Order.Table (Elab_Order.Last) := Chosen;
 456
 457       --  Remove from No_Pred list. This is a little inefficient and may
 458       --  be we should doubly link the list, but it will do for now!
 459
 460       if No_Pred = Chosen then
 461          No_Pred := UNR.Table (Chosen).Nextnp;
 462
 463       else
 464          --  Note that we just ignore the situation where it does not
 465          --  appear in the No_Pred list, this happens in calls from the
 466          --  Diagnose_Elaboration_Problem routine, where cycles are being
 467          --  removed arbitrarily from the graph.
 468
 469          U := No_Pred;
 470          while U /= No_Unit_Id loop
 471             if UNR.Table (U).Nextnp = Chosen then
 472                UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp;
 473                exit;
 474             end if;
 475
 476             U := UNR.Table (U).Nextnp;
 477          end loop;
 478       end if;
 479
 480       --  For all successors, decrement the number of predecessors, and
 481       --  if it becomes zero, then add to no predecessor list.
 482
 483       S := UNR.Table (Chosen).Successors;
 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    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 this with is an interface to a stand-alone library.
 769          --  Skip also if no ALI file for this with, happens with certain
 770          --  specialized generic files that do not get compiled.
 771
 772          if not Withs.Table (W).SAL_Interface
 773            and then Withs.Table (W).Afile /= No_File
 774            and then Generic_Separately_Compiled (Withs.Table (W).Sfile)
 775          then
 776             Elab_All_Links
 777               (Unit_Id_Of (Withs.Table (W).Uname),
 778                After,
 779                Reason,
 780                Make_Elab_Entry (Withs.Table (W).Uname, Link));
 781          end if;
 782       end loop;
 783
 784       --  Process corresponding body, if there is one
 785
 786       if Units.Table (Before).Utype = Is_Spec then
 787          Elab_All_Links
 788            (Corresponding_Body (Before),
 789             After, Reason,
 790             Make_Elab_Entry
 791               (Units.Table (Corresponding_Body (Before)).Uname, Link));
 792       end if;
 793    end Elab_All_Links;
 794
 795    --------------------
 796    -- Elab_Error_Msg --
 797    --------------------
 798
 799    procedure Elab_Error_Msg (S : Successor_Id) is
 800       SL : Successor_Link renames Succ.Table (S);
 801
 802    begin
 803       --  Nothing to do if internal unit involved and no -de flag
 804
 805       if not Debug_Flag_E
 806         and then
 807           (Is_Internal_File_Name (Units.Table (SL.Before).Sfile)
 808             or else
 809            Is_Internal_File_Name (Units.Table (SL.After).Sfile))
 810       then
 811          return;
 812       end if;
 813
 814       --  Here we want to generate output
 815
 816       Error_Msg_Name_1 := Units.Table (SL.Before).Uname;
 817
 818       if SL.Elab_Body then
 819          Error_Msg_Name_2 := Units.Table (Corresponding_Body (SL.After)).Uname;
 820       else
 821          Error_Msg_Name_2 := Units.Table (SL.After).Uname;
 822       end if;
 823
 824       Error_Msg_Output ("  & must be elaborated before &", Info => True);
 825
 826       Error_Msg_Name_1 := Units.Table (SL.Reason_Unit).Uname;
 827
 828       case SL.Reason is
 829          when Withed =>
 830             Error_Msg_Output
 831               ("     reason: with clause",
 832                Info => True);
 833
 834          when Elab =>
 835             Error_Msg_Output
 836               ("     reason: pragma Elaborate in unit &",
 837                Info => True);
 838
 839          when Elab_All =>
 840             Error_Msg_Output
 841               ("     reason: pragma Elaborate_All in unit &",
 842                Info => True);
 843
 844          when Elab_Desirable =>
 845             Error_Msg_Output
 846               ("     reason: implicit Elaborate_All in unit &",
 847                Info => True);
 848
 849             Error_Msg_Output
 850               ("     recompile & with -gnatwl for full details",
 851                Info => True);
 852
 853          when Spec_First =>
 854             Error_Msg_Output
 855               ("     reason: spec always elaborated before body",
 856                Info => True);
 857       end case;
 858
 859       Write_Elab_All_Chain (S);
 860
 861       if SL.Elab_Body then
 862          Error_Msg_Name_1 := Units.Table (SL.Before).Uname;
 863          Error_Msg_Name_2 := Units.Table (SL.After).Uname;
 864          Error_Msg_Output
 865            ("  & must therefore be elaborated before &",
 866             True);
 867
 868          Error_Msg_Name_1 := Units.Table (SL.After).Uname;
 869          Error_Msg_Output
 870            ("     (because & has a pragma Elaborate_Body)",
 871             True);
 872       end if;
 873
 874       Write_Eol;
 875    end Elab_Error_Msg;
 876
 877    ---------------------
 878    -- Find_Elab_Order --
 879    ---------------------
 880
 881    procedure Find_Elab_Order is
 882       U           : Unit_Id;
 883       Best_So_Far : Unit_Id;
 884
 885    begin
 886       Succ.Init;
 887       Num_Left := Int (Units.Last - Units.First + 1);
 888
 889       --  Initialize unit table for elaboration control
 890
 891       for U in Units.First .. Units.Last loop
 892          UNR.Increment_Last;
 893          UNR.Table (UNR.Last).Successors    := No_Successor;
 894          UNR.Table (UNR.Last).Num_Pred      := 0;
 895          UNR.Table (UNR.Last).Nextnp        := No_Unit_Id;
 896          UNR.Table (UNR.Last).Elab_Order    := 0;
 897          UNR.Table (UNR.Last).Elab_Position := 0;
 898       end loop;
 899
 900       --  Output warning if -p used with no -gnatE units
 901
 902       if Pessimistic_Elab_Order
 903         and not Dynamic_Elaboration_Checks_Specified
 904       then
 905          if OpenVMS_On_Target then
 906             Error_Msg ("?use of /PESSIMISTIC_ELABORATION questionable");
 907          else
 908             Error_Msg ("?use of -p switch questionable");
 909          end if;
 910
 911          Error_Msg ("?since all units compiled with static elaboration model");
 912       end if;
 913
 914       --  Gather dependencies and output them if option set
 915
 916       Gather_Dependencies;
 917
 918       --  Output elaboration dependencies if option is set
 919
 920       if Elab_Dependency_Output or Debug_Flag_E then
 921          Write_Dependencies;
 922       end if;
 923
 924       --  Initialize the no predecessor list
 925
 926       No_Pred := No_Unit_Id;
 927
 928       for U in UNR.First .. UNR.Last loop
 929          if UNR.Table (U).Num_Pred = 0 then
 930             UNR.Table (U).Nextnp := No_Pred;
 931             No_Pred := U;
 932          end if;
 933       end loop;
 934
 935       --  OK, now we determine the elaboration order proper. All we do is to
 936       --  select the best choice from the no predecessor list until all the
 937       --  nodes have been chosen.
 938
 939       Outer : loop
 940
 941          --  If there are no nodes with predecessors, then either we are
 942          --  done, as indicated by Num_Left being set to zero, or we have
 943          --  a circularity. In the latter case, diagnose the circularity,
 944          --  removing it from the graph and continue
 945
 946          Get_No_Pred : while No_Pred = No_Unit_Id loop
 947             exit Outer when Num_Left < 1;
 948             Diagnose_Elaboration_Problem;
 949          end loop Get_No_Pred;
 950
 951          U := No_Pred;
 952          Best_So_Far := No_Unit_Id;
 953
 954          --  Loop to choose best entry in No_Pred list
 955
 956          No_Pred_Search : loop
 957             if Debug_Flag_N then
 958                Write_Str ("  considering choice of ");
 959                Write_Unit_Name (Units.Table (U).Uname);
 960                Write_Eol;
 961
 962                if Units.Table (U).Elaborate_Body then
 963                   Write_Str
 964                     ("    Elaborate_Body = True, Num_Pred for body = ");
 965                   Write_Int
 966                     (Int (UNR.Table (Corresponding_Body (U)).Num_Pred));
 967                else
 968                   Write_Str
 969                     ("    Elaborate_Body = False");
 970                end if;
 971
 972                Write_Eol;
 973             end if;
 974
 975             --  This is a candididate to be considered for choice
 976
 977             if Best_So_Far = No_Unit_Id
 978               or else ((not Pessimistic_Elab_Order)
 979                          and then Better_Choice (U, Best_So_Far))
 980               or else (Pessimistic_Elab_Order
 981                          and then Worse_Choice (U, Best_So_Far))
 982             then
 983                if Debug_Flag_N then
 984                   Write_Str ("    tentatively chosen (best so far)");
 985                   Write_Eol;
 986                end if;
 987
 988                Best_So_Far := U;
 989             end if;
 990
 991             U := UNR.Table (U).Nextnp;
 992             exit No_Pred_Search when U = No_Unit_Id;
 993          end loop No_Pred_Search;
 994
 995          --  If no candididate chosen, it means that no unit has No_Pred = 0,
 996          --  but there are units left, hence we have a circular dependency,
 997          --  which we will get Diagnose_Elaboration_Problem to diagnose it.
 998
 999          if Best_So_Far = No_Unit_Id then
1000             Diagnose_Elaboration_Problem;
1001
1002          --  Otherwise choose the best candidate found
1003
1004          else
1005             Choose (Best_So_Far);
1006          end if;
1007       end loop Outer;
1008
1009    end Find_Elab_Order;
1010
1011    -------------------------
1012    -- Gather_Dependencies --
1013    -------------------------
1014
1015    procedure Gather_Dependencies is
1016       Withed_Unit : Unit_Id;
1017
1018    begin
1019       --  Loop through all units
1020
1021       for U in Units.First .. Units.Last loop
1022          Cur_Unit := U;
1023
1024          --  If this is not an interface to a stand-alone library and
1025          --  there is a body and a spec, then spec must be elaborated first
1026          --  Note that the corresponding spec immediately follows the body
1027
1028          if not Units.Table (U).SAL_Interface
1029            and then Units.Table (U).Utype = Is_Body
1030          then
1031             Build_Link (Corresponding_Spec (U), U, Spec_First);
1032          end if;
1033
1034          --  If this unit is not an interface to a stand-alone library,
1035          --  process WITH references for this unit ignoring generic units and
1036          --  interfaces to stand-alone libraries.
1037
1038          if not Units.Table (U).SAL_Interface then
1039             for
1040               W in Units.Table (U).First_With .. Units.Table (U).Last_With
1041             loop
1042                if Withs.Table (W).Sfile /= No_File
1043                  and then (not Withs.Table (W).SAL_Interface)
1044                then
1045                   --  Check for special case of withing a unit that does not
1046                   --  exist any more. If the unit was completely missing we
1047                   --  would already have detected this, but a nasty case arises
1048                   --  when we have a subprogram body with no spec, and some
1049                   --  obsolete unit with's a previous (now disappeared) spec.
1050
1051                   if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then
1052                      Error_Msg_Name_1 := Units.Table (U).Sfile;
1053                      Error_Msg_Name_2 := Withs.Table (W).Uname;
1054                      Error_Msg ("% depends on & which no longer exists");
1055                      goto Next_With;
1056                   end if;
1057
1058                   Withed_Unit :=
1059                     Unit_Id (Unit_Id_Of (Withs.Table (W).Uname));
1060
1061                   --  Pragma Elaborate_All case, for this we use the recursive
1062                   --  Elab_All_Links procedure to establish the links.
1063
1064                   if Withs.Table (W).Elaborate_All then
1065
1066                      --  Reset flags used to stop multiple visits to a given
1067                      --  node.
1068
1069                      for Uref in UNR.First .. UNR.Last loop
1070                         UNR.Table (Uref).Visited := False;
1071                      end loop;
1072
1073                      --  Now establish all the links we need
1074
1075                      Elab_All_Links
1076                        (Withed_Unit, U, Elab_All,
1077                         Make_Elab_Entry
1078                           (Withs.Table (W).Uname, No_Elab_All_Link));
1079
1080                      --  Elaborate_All_Desirable case, for this we establish
1081                      --  the same links as above, but with a different reason.
1082
1083                   elsif Withs.Table (W).Elab_All_Desirable then
1084
1085                      --  Reset flags used to stop multiple visits to a given
1086                      --  node.
1087
1088                      for Uref in UNR.First .. UNR.Last loop
1089                         UNR.Table (Uref).Visited := False;
1090                      end loop;
1091
1092                      --  Now establish all the links we need
1093
1094                      Elab_All_Links
1095                        (Withed_Unit, U, Elab_Desirable,
1096                         Make_Elab_Entry
1097                           (Withs.Table (W).Uname, No_Elab_All_Link));
1098
1099                      --  Pragma Elaborate case. We must build a link for the
1100                      --  withed unit itself, and also the corresponding body
1101                      --  if there is one.
1102
1103                      --  However, skip this processing if there is no ALI file
1104                      --  for the WITH entry, because this means it is a
1105                      --  generic (even when we fix the generics so that an ALI
1106                      --  file is present, we probably still will have no ALI
1107                      --  file for unchecked and other special cases).
1108
1109                   elsif Withs.Table (W).Elaborate
1110                     and then Withs.Table (W).Afile /= No_File
1111                   then
1112                      Build_Link (Withed_Unit, U, Withed);
1113
1114                      if Units.Table (Withed_Unit).Utype = Is_Spec then
1115                         Build_Link
1116                           (Corresponding_Body (Withed_Unit), U, Elab);
1117                      end if;
1118
1119                      --  Case of normal WITH with no elaboration pragmas, just
1120                      --  build the single link to the directly referenced unit
1121
1122                   else
1123                      Build_Link (Withed_Unit, U, Withed);
1124                   end if;
1125                end if;
1126
1127                <<Next_With>>
1128                null;
1129             end loop;
1130          end if;
1131       end loop;
1132    end Gather_Dependencies;
1133
1134    ---------------------
1135    -- Make_Elab_Entry --
1136    ---------------------
1137
1138    function Make_Elab_Entry
1139      (Unam : Unit_Name_Type;
1140       Link : Elab_All_Id)
1141       return Elab_All_Id
1142    is
1143    begin
1144       Elab_All_Entries.Increment_Last;
1145       Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam;
1146       Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link;
1147       return Elab_All_Entries.Last;
1148    end Make_Elab_Entry;
1149
1150    ----------------
1151    -- Unit_Id_Of --
1152    ----------------
1153
1154    function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
1155       Info : constant Int := Get_Name_Table_Info (Uname);
1156
1157    begin
1158       pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
1159       return Unit_Id (Info);
1160    end Unit_Id_Of;
1161
1162    ------------------
1163    -- Worse_Choice --
1164    ------------------
1165
1166    function Worse_Choice (U1, U2 : Unit_Id) return Boolean is
1167
1168       function Body_Unit (U : Unit_Id) return Boolean;
1169       --  Determines if given unit is a body
1170
1171       function Waiting_Body (U : Unit_Id) return Boolean;
1172       --  Determines if U is a waiting body, defined as a body which has
1173       --  not been elaborated, but whose spec has been elaborated.
1174
1175       function Body_Unit (U : Unit_Id) return Boolean is
1176       begin
1177          return Units.Table (U).Utype = Is_Body
1178            or else Units.Table (U).Utype = Is_Body_Only;
1179       end Body_Unit;
1180
1181       function Waiting_Body (U : Unit_Id) return Boolean is
1182       begin
1183          return Units.Table (U).Utype = Is_Body and then
1184             UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
1185       end Waiting_Body;
1186
1187    --  Start of processing for Worse_Choice
1188
1189    --  Note: the checks here are applied in sequence, and the ordering is
1190    --  significant (i.e. the more important criteria are applied first).
1191
1192    begin
1193       --  If either unit is internal, then use Better_Choice, since the
1194       --  language requires that predefined units not mess up in the choice
1195       --  of elaboration order, and for internal units, any problems are
1196       --  ours and not the programmers.
1197
1198       if Units.Table (U1).Internal or else Units.Table (U2).Internal then
1199          return Better_Choice (U1, U2);
1200
1201       --  Prefer anything else to a waiting body (!)
1202
1203       elsif Waiting_Body (U1) and not Waiting_Body (U2) then
1204          return False;
1205
1206       elsif Waiting_Body (U2) and not Waiting_Body (U1) then
1207          return True;
1208
1209       --  Prefer a spec to a body (!)
1210
1211       elsif Body_Unit (U1) and not Body_Unit (U2) then
1212          return False;
1213
1214       elsif Body_Unit (U2) and not Body_Unit (U1) then
1215          return True;
1216
1217       --  If both are waiting bodies, then prefer the one whose spec is
1218       --  less recently elaborated. Consider the following:
1219
1220       --     spec of A
1221       --     spec of B
1222       --     body of A or B?
1223
1224       --  The normal waiting body preference would have placed the body of
1225       --  A before the spec of B if it could. Since it could not, there it
1226       --  must be the case that A depends on B. It is therefore a good idea
1227       --  to put the body of B last so that if there is an elaboration order
1228       --  problem, we will find it (that's what horrible order is about)
1229
1230       elsif Waiting_Body (U1) and then Waiting_Body (U2) then
1231          return
1232            UNR.Table (Corresponding_Spec (U1)).Elab_Position <
1233            UNR.Table (Corresponding_Spec (U2)).Elab_Position;
1234
1235       --  Otherwise decide on the basis of alphabetical order. We do not try
1236       --  to reverse the usual choice here, since it can cause cancelling
1237       --  errors with the other inversions.
1238
1239       else
1240          return Uname_Less (Units.Table (U1).Uname, Units.Table (U2).Uname);
1241       end if;
1242    end Worse_Choice;
1243
1244    ------------------------
1245    -- Write_Dependencies --
1246    ------------------------
1247
1248    procedure Write_Dependencies is
1249    begin
1250       Write_Eol;
1251       Write_Str
1252         ("                 ELABORATION ORDER DEPENDENCIES");
1253       Write_Eol;
1254       Write_Eol;
1255
1256       Info_Prefix_Suppress := True;
1257
1258       for S in Succ_First .. Succ.Last loop
1259          Elab_Error_Msg (S);
1260       end loop;
1261
1262       Info_Prefix_Suppress := False;
1263       Write_Eol;
1264    end Write_Dependencies;
1265
1266    --------------------------
1267    -- Write_Elab_All_Chain --
1268    --------------------------
1269
1270    procedure Write_Elab_All_Chain (S : Successor_Id) is
1271       ST     : constant Successor_Link := Succ.Table (S);
1272       After  : constant Unit_Name_Type := Units.Table (ST.After).Uname;
1273
1274       L   : Elab_All_Id;
1275       Nam : Unit_Name_Type;
1276
1277       First_Name : Boolean := True;
1278
1279    begin
1280       if ST.Reason in Elab_All .. Elab_Desirable then
1281          L := ST.Elab_All_Link;
1282          while L /= No_Elab_All_Link loop
1283             Nam := Elab_All_Entries.Table (L).Needed_By;
1284             Error_Msg_Name_1 := Nam;
1285             Error_Msg_Output ("        &", Info => True);
1286
1287             Get_Name_String (Nam);
1288
1289             if Name_Buffer (Name_Len) = 'b' then
1290                if First_Name then
1291                   Error_Msg_Output
1292                     ("           must be elaborated along with its spec:",
1293                      Info => True);
1294
1295                else
1296                   Error_Msg_Output
1297                     ("           which must be elaborated " &
1298                      "along with its spec:",
1299                      Info => True);
1300                end if;
1301
1302             else
1303                if First_Name then
1304                   Error_Msg_Output
1305                     ("           is withed by:",
1306                      Info => True);
1307
1308                else
1309                   Error_Msg_Output
1310                     ("           which is withed by:",
1311                      Info => True);
1312                end if;
1313             end if;
1314
1315             First_Name := False;
1316
1317             L := Elab_All_Entries.Table (L).Next_Elab;
1318          end loop;
1319
1320          Error_Msg_Name_1 := After;
1321          Error_Msg_Output ("        &", Info => True);
1322       end if;
1323    end Write_Elab_All_Chain;
1324
1325 end Binde;