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