From 1bc5aee63eb72b341f506ad058502cd0361f0d10 Mon Sep 17 00:00:00 2001 From: Ben Cheng Date: Tue, 25 Mar 2014 22:37:19 -0700 Subject: Initial checkin of GCC 4.9.0 from trunk (r208799). Change-Id: I48a3c08bb98542aa215912a75f03c0890e497dba --- gcc-4.9/gcc/ada/binde.adb | 1705 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1705 insertions(+) create mode 100644 gcc-4.9/gcc/ada/binde.adb (limited to 'gcc-4.9/gcc/ada/binde.adb') diff --git a/gcc-4.9/gcc/ada/binde.adb b/gcc-4.9/gcc/ada/binde.adb new file mode 100644 index 000000000..935e09e9d --- /dev/null +++ b/gcc-4.9/gcc/ada/binde.adb @@ -0,0 +1,1705 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- B I N D E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Binderr; use Binderr; +with Butil; use Butil; +with Debug; use Debug; +with Fname; use Fname; +with Namet; use Namet; +with Opt; use Opt; +with Osint; +with Output; use Output; +with Targparm; use Targparm; + +with System.Case_Util; use System.Case_Util; + +package body Binde is + + -- The following data structures are used to represent the graph that is + -- used to determine the elaboration order (using a topological sort). + + -- The following structures are used to record successors. If A is a + -- successor of B in this table, it means that A must be elaborated + -- before B is elaborated. + + type Successor_Id is new Nat; + -- Identification of single successor entry + + No_Successor : constant Successor_Id := 0; + -- Used to indicate end of list of successors + + type Elab_All_Id is new Nat; + -- Identification of Elab_All entry link + + No_Elab_All_Link : constant Elab_All_Id := 0; + -- Used to indicate end of list + + -- Succ_Reason indicates the reason for a particular elaboration link + + type Succ_Reason is + (Withed, + -- After directly with's Before, so the spec of Before must be + -- elaborated before After is elaborated. + + Elab, + -- After directly mentions Before in a pragma Elaborate, so the + -- body of Before must be elaborate before After is elaborated. + + Elab_All, + -- After either mentions Before directly in a pragma Elaborate_All, + -- or mentions a third unit, X, which itself requires that Before be + -- elaborated before unit X is elaborated. The Elab_All_Link list + -- traces the dependencies in the latter case. + + Elab_All_Desirable, + -- This is just like Elab_All, except that the elaborate all was not + -- explicitly present in the source, but rather was created by the + -- front end, which decided that it was "desirable". + + Elab_Desirable, + -- This is just like Elab, except that the elaborate was not + -- explicitly present in the source, but rather was created by the + -- front end, which decided that it was "desirable". + + Spec_First); + -- After is a body, and Before is the corresponding spec + + -- Successor_Link contains the information for one link + + type Successor_Link is record + Before : Unit_Id; + -- Predecessor unit + + After : Unit_Id; + -- Successor unit + + Next : Successor_Id; + -- Next successor on this list + + Reason : Succ_Reason; + -- Reason for this link + + Elab_Body : Boolean; + -- Set True if this link is needed for the special Elaborate_Body + -- processing described below. + + Reason_Unit : Unit_Id; + -- For Reason = Elab, or Elab_All or Elab_Desirable, records the unit + -- containing the pragma leading to the link. + + Elab_All_Link : Elab_All_Id; + -- If Reason = Elab_All or Elab_Desirable, then this points to the + -- first elment in a list of Elab_All entries that record the with + -- chain leading resulting in this particular dependency. + + end record; + + -- Note on handling of Elaborate_Body. Basically, if we have a pragma + -- Elaborate_Body in a unit, it means that the spec and body have to + -- be handled as a single entity from the point of view of determining + -- an elaboration order. What we do is to essentially remove the body + -- from consideration completely, and transfer all its links (other + -- than the spec link) to the spec. Then when then the spec gets chosen, + -- we choose the body right afterwards. We mark the links that get moved + -- from the body to the spec by setting their Elab_Body flag True, so + -- that we can understand what is going on. + + Succ_First : constant := 1; + + package Succ is new Table.Table ( + Table_Component_Type => Successor_Link, + Table_Index_Type => Successor_Id, + Table_Low_Bound => Succ_First, + Table_Initial => 500, + Table_Increment => 200, + Table_Name => "Succ"); + + -- For the case of Elaborate_All, the following table is used to record + -- chains of with relationships that lead to the Elab_All link. These + -- are used solely for diagnostic purposes + + type Elab_All_Entry is record + Needed_By : Unit_Name_Type; + -- Name of unit from which referencing unit was with'ed or otherwise + -- needed as a result of Elaborate_All or Elaborate_Desirable. + + Next_Elab : Elab_All_Id; + -- Link to next entry on chain (No_Elab_All_Link marks end of list) + end record; + + package Elab_All_Entries is new Table.Table ( + Table_Component_Type => Elab_All_Entry, + Table_Index_Type => Elab_All_Id, + Table_Low_Bound => 1, + Table_Initial => 2000, + Table_Increment => 200, + Table_Name => "Elab_All_Entries"); + + -- A Unit_Node record is built for each active unit + + type Unit_Node_Record is record + + Successors : Successor_Id; + -- Pointer to list of links for successor nodes + + Num_Pred : Int; + -- Number of predecessors for this unit. Normally non-negative, but + -- can go negative in the case of units chosen by the diagnose error + -- procedure (when cycles are being removed from the graph). + + Nextnp : Unit_Id; + -- Forward pointer for list of units with no predecessors + + Elab_Order : Nat; + -- Position in elaboration order (zero = not placed yet) + + Visited : Boolean; + -- Used in computing transitive closure for elaborate all and + -- also in locating cycles and paths in the diagnose routines. + + Elab_Position : Natural; + -- Initialized to zero. Set non-zero when a unit is chosen and + -- placed in the elaboration order. The value represents the + -- ordinal position in the elaboration order. + + end record; + + package UNR is new Table.Table ( + Table_Component_Type => Unit_Node_Record, + Table_Index_Type => Unit_Id, + Table_Low_Bound => First_Unit_Entry, + Table_Initial => 500, + Table_Increment => 200, + Table_Name => "UNR"); + + No_Pred : Unit_Id; + -- Head of list of items with no predecessors + + Num_Left : Int; + -- Number of entries not yet dealt with + + Cur_Unit : Unit_Id; + -- Current unit, set by Gather_Dependencies, and picked up in Build_Link + -- to set the Reason_Unit field of the created dependency link. + + Num_Chosen : Natural := 0; + -- Number of units chosen in the elaboration order so far + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Better_Choice (U1, U2 : Unit_Id) return Boolean; + -- U1 and U2 are both permitted candidates for selection as the next unit + -- to be elaborated. This function determines whether U1 is a better choice + -- than U2, i.e. should be elaborated in preference to U2, based on a set + -- of heuristics that establish a friendly and predictable order (see body + -- for details). The result is True if U1 is a better choice than U2, and + -- False if it is a worse choice, or there is no preference between them. + + procedure Build_Link + (Before : Unit_Id; + After : Unit_Id; + R : Succ_Reason; + Ea_Id : Elab_All_Id := No_Elab_All_Link); + -- Establish a successor link, Before must be elaborated before After, and + -- the reason for the link is R. Ea_Id is the contents to be placed in the + -- Elab_All_Link of the entry. + + procedure Choose (Chosen : Unit_Id); + -- Chosen is the next entry chosen in the elaboration order. This procedure + -- updates all data structures appropriately. + + function Corresponding_Body (U : Unit_Id) return Unit_Id; + pragma Inline (Corresponding_Body); + -- Given a unit which is a spec for which there is a separate body, return + -- the unit id of the body. It is an error to call this routine with a unit + -- that is not a spec, or which does not have a separate body. + + function Corresponding_Spec (U : Unit_Id) return Unit_Id; + pragma Inline (Corresponding_Spec); + -- Given a unit which is a body for which there is a separate spec, return + -- the unit id of the spec. It is an error to call this routine with a unit + -- that is not a body, or which does not have a separate spec. + + procedure Diagnose_Elaboration_Problem; + -- Called when no elaboration order can be found. Outputs an appropriate + -- diagnosis of the problem, and then abandons the bind. + + procedure Elab_All_Links + (Before : Unit_Id; + After : Unit_Id; + Reason : Succ_Reason; + Link : Elab_All_Id); + -- Used to compute the transitive closure of elaboration links for an + -- Elaborate_All pragma (Reason = Elab_All) or for an indication of + -- Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has + -- a pragma Elaborate_All or the front end has determined that a reference + -- probably requires Elaborate_All is required, and unit Before must be + -- previously elaborated. First a link is built making sure that unit + -- Before is elaborated before After, then a recursive call ensures that + -- we also build links for any units needed by Before (i.e. these units + -- must/should also be elaborated before After). Link is used to build + -- a chain of Elab_All_Entries to explain the reason for a link. The + -- value passed is the chain so far. + + procedure Elab_Error_Msg (S : Successor_Id); + -- Given a successor link, outputs an error message of the form + -- "$ must be elaborated before $ ..." where ... is the reason. + + procedure Gather_Dependencies; + -- Compute dependencies, building the Succ and UNR tables + + function Is_Body_Unit (U : Unit_Id) return Boolean; + pragma Inline (Is_Body_Unit); + -- Determines if given unit is a body + + function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean; + -- Returns True if corresponding unit is Pure or Preelaborate. Includes + -- dealing with testing flags on spec if it is given a body. + + function Is_Waiting_Body (U : Unit_Id) return Boolean; + pragma Inline (Is_Waiting_Body); + -- Determines if U is a waiting body, defined as a body which has + -- not been elaborated, but whose spec has been elaborated. + + function Make_Elab_Entry + (Unam : Unit_Name_Type; + Link : Elab_All_Id) return Elab_All_Id; + -- Make an Elab_All_Entries table entry with the given Unam and Link + + function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean; + -- This is like Better_Choice, and has the same interface, but returns + -- true if U1 is a worse choice than U2 in the sense of the -p (pessimistic + -- elaboration order) switch. We still have to obey Ada rules, so it is + -- not quite the direct inverse of Better_Choice. + + function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id; + -- This function uses the Info field set in the names table to obtain + -- the unit Id of a unit, given its name id value. + + procedure Write_Dependencies; + -- Write out dependencies (called only if appropriate option is set) + + procedure Write_Elab_All_Chain (S : Successor_Id); + -- If the reason for the link S is Elaborate_All or Elaborate_Desirable, + -- then this routine will output the "needed by" explanation chain. + + ------------------- + -- Better_Choice -- + ------------------- + + function Better_Choice (U1, U2 : Unit_Id) return Boolean is + UT1 : Unit_Record renames Units.Table (U1); + UT2 : Unit_Record renames Units.Table (U2); + + begin + if Debug_Flag_B then + Write_Str ("Better_Choice ("); + Write_Unit_Name (UT1.Uname); + Write_Str (", "); + Write_Unit_Name (UT2.Uname); + Write_Line (")"); + end if; + + -- Note: the checks here are applied in sequence, and the ordering is + -- significant (i.e. the more important criteria are applied first). + + -- Prefer a waiting body to one that is not a waiting body + + if Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then + if Debug_Flag_B then + Write_Line (" True: u1 is waiting body, u2 is not"); + end if; + + return True; + + elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then + if Debug_Flag_B then + Write_Line (" False: u2 is waiting body, u1 is not"); + end if; + + return False; + + -- Prefer a predefined unit to a non-predefined unit + + elsif UT1.Predefined and then not UT2.Predefined then + if Debug_Flag_B then + Write_Line (" True: u1 is predefined, u2 is not"); + end if; + + return True; + + elsif UT2.Predefined and then not UT1.Predefined then + if Debug_Flag_B then + Write_Line (" False: u2 is predefined, u1 is not"); + end if; + + return False; + + -- Prefer an internal unit to a non-internal unit + + elsif UT1.Internal and then not UT2.Internal then + if Debug_Flag_B then + Write_Line (" True: u1 is internal, u2 is not"); + end if; + return True; + + elsif UT2.Internal and then not UT1.Internal then + if Debug_Flag_B then + Write_Line (" False: u2 is internal, u1 is not"); + end if; + + return False; + + -- Prefer a pure or preelaborable unit to one that is not + + elsif Is_Pure_Or_Preelab_Unit (U1) + and then not + Is_Pure_Or_Preelab_Unit (U2) + then + if Debug_Flag_B then + Write_Line (" True: u1 is pure/preelab, u2 is not"); + end if; + + return True; + + elsif Is_Pure_Or_Preelab_Unit (U2) + and then not + Is_Pure_Or_Preelab_Unit (U1) + then + if Debug_Flag_B then + Write_Line (" False: u2 is pure/preelab, u1 is not"); + end if; + + return False; + + -- Prefer a body to a spec + + elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then + if Debug_Flag_B then + Write_Line (" True: u1 is body, u2 is not"); + end if; + + return True; + + elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then + if Debug_Flag_B then + Write_Line (" False: u2 is body, u1 is not"); + end if; + + return False; + + -- If both are waiting bodies, then prefer the one whose spec is + -- more recently elaborated. Consider the following: + + -- spec of A + -- spec of B + -- body of A or B? + + -- The normal waiting body preference would have placed the body of + -- A before the spec of B if it could. Since it could not, there it + -- must be the case that A depends on B. It is therefore a good idea + -- to put the body of B first. + + elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then + declare + Result : constant Boolean := + UNR.Table (Corresponding_Spec (U1)).Elab_Position > + UNR.Table (Corresponding_Spec (U2)).Elab_Position; + begin + if Debug_Flag_B then + if Result then + Write_Line (" True: based on waiting body elab positions"); + else + Write_Line (" False: based on waiting body elab positions"); + end if; + end if; + + return Result; + end; + end if; + + -- Remaining choice rules are disabled by Debug flag -do + + if not Debug_Flag_O then + + -- The following deal with the case of specs which have been marked + -- as Elaborate_Body_Desirable. We generally want to delay these + -- specs as long as possible, so that the bodies have a better chance + -- of being elaborated closer to the specs. + + -- If we have two units, one of which is a spec for which this flag + -- is set, and the other is not, we prefer to delay the spec for + -- which the flag is set. + + if not UT1.Elaborate_Body_Desirable + and then UT2.Elaborate_Body_Desirable + then + if Debug_Flag_B then + Write_Line (" True: u1 is elab body desirable, u2 is not"); + end if; + + return True; + + elsif not UT2.Elaborate_Body_Desirable + and then UT1.Elaborate_Body_Desirable + then + if Debug_Flag_B then + Write_Line (" False: u1 is elab body desirable, u2 is not"); + end if; + + return False; + + -- If we have two specs that are both marked as Elaborate_Body + -- desirable, we prefer the one whose body is nearer to being able + -- to be elaborated, based on the Num_Pred count. This helps to + -- ensure bodies are as close to specs as possible. + + elsif UT1.Elaborate_Body_Desirable + and then UT2.Elaborate_Body_Desirable + then + declare + Result : constant Boolean := + UNR.Table (Corresponding_Body (U1)).Num_Pred < + UNR.Table (Corresponding_Body (U2)).Num_Pred; + begin + if Debug_Flag_B then + if Result then + Write_Line (" True based on Num_Pred compare"); + else + Write_Line (" False based on Num_Pred compare"); + end if; + end if; + + return Result; + end; + end if; + end if; + + -- If we fall through, it means that no preference rule applies, so we + -- use alphabetical order to at least give a deterministic result. + + if Debug_Flag_B then + Write_Line (" choose on alpha order"); + end if; + + return Uname_Less (UT1.Uname, UT2.Uname); + end Better_Choice; + + ---------------- + -- Build_Link -- + ---------------- + + procedure Build_Link + (Before : Unit_Id; + After : Unit_Id; + R : Succ_Reason; + Ea_Id : Elab_All_Id := No_Elab_All_Link) + is + Cspec : Unit_Id; + + begin + Succ.Increment_Last; + Succ.Table (Succ.Last).Before := Before; + Succ.Table (Succ.Last).Next := UNR.Table (Before).Successors; + UNR.Table (Before).Successors := Succ.Last; + Succ.Table (Succ.Last).Reason := R; + Succ.Table (Succ.Last).Reason_Unit := Cur_Unit; + Succ.Table (Succ.Last).Elab_All_Link := Ea_Id; + + -- Deal with special Elab_Body case. If the After of this link is + -- a body whose spec has Elaborate_All set, and this is not the link + -- directly from the body to the spec, then we make the After of the + -- link reference its spec instead, marking the link appropriately. + + if Units.Table (After).Utype = Is_Body then + Cspec := Corresponding_Spec (After); + + if Units.Table (Cspec).Elaborate_Body + and then Cspec /= Before + then + Succ.Table (Succ.Last).After := Cspec; + Succ.Table (Succ.Last).Elab_Body := True; + UNR.Table (Cspec).Num_Pred := UNR.Table (Cspec).Num_Pred + 1; + return; + end if; + end if; + + -- Fall through on normal case + + Succ.Table (Succ.Last).After := After; + Succ.Table (Succ.Last).Elab_Body := False; + UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1; + end Build_Link; + + ------------ + -- Choose -- + ------------ + + procedure Choose (Chosen : Unit_Id) is + S : Successor_Id; + U : Unit_Id; + + begin + if Debug_Flag_C then + Write_Str ("Choosing Unit "); + Write_Unit_Name (Units.Table (Chosen).Uname); + Write_Eol; + end if; + + -- Add to elaboration order. Note that units having no elaboration + -- code are not treated specially yet. The special casing of this + -- is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile + -- we need them here, because the object file list is also driven + -- by the contents of the Elab_Order table. + + Elab_Order.Increment_Last; + Elab_Order.Table (Elab_Order.Last) := Chosen; + + -- Remove from No_Pred list. This is a little inefficient and may + -- be we should doubly link the list, but it will do for now. + + if No_Pred = Chosen then + No_Pred := UNR.Table (Chosen).Nextnp; + + else + -- Note that we just ignore the situation where it does not + -- appear in the No_Pred list, this happens in calls from the + -- Diagnose_Elaboration_Problem routine, where cycles are being + -- removed arbitrarily from the graph. + + U := No_Pred; + while U /= No_Unit_Id loop + if UNR.Table (U).Nextnp = Chosen then + UNR.Table (U).Nextnp := UNR.Table (Chosen).Nextnp; + exit; + end if; + + U := UNR.Table (U).Nextnp; + end loop; + end if; + + -- For all successors, decrement the number of predecessors, and + -- if it becomes zero, then add to no predecessor list. + + S := UNR.Table (Chosen).Successors; + while S /= No_Successor loop + U := Succ.Table (S).After; + UNR.Table (U).Num_Pred := UNR.Table (U).Num_Pred - 1; + + if Debug_Flag_N then + Write_Str (" decrementing Num_Pred for unit "); + Write_Unit_Name (Units.Table (U).Uname); + Write_Str (" new value = "); + Write_Int (UNR.Table (U).Num_Pred); + Write_Eol; + end if; + + if UNR.Table (U).Num_Pred = 0 then + UNR.Table (U).Nextnp := No_Pred; + No_Pred := U; + end if; + + S := Succ.Table (S).Next; + end loop; + + -- All done, adjust number of units left count and set elaboration pos + + Num_Left := Num_Left - 1; + Num_Chosen := Num_Chosen + 1; + UNR.Table (Chosen).Elab_Position := Num_Chosen; + Units.Table (Chosen).Elab_Position := Num_Chosen; + + -- If we just chose a spec with Elaborate_Body set, then we + -- must immediately elaborate the body, before any other units. + + if Units.Table (Chosen).Elaborate_Body then + + -- If the unit is a spec only, then there is no body. This is a bit + -- odd given that Elaborate_Body is here, but it is valid in an + -- RCI unit, where we only have the interface in the stub bind. + + if Units.Table (Chosen).Utype = Is_Spec_Only + and then Units.Table (Chosen).RCI + then + null; + else + Choose (Corresponding_Body (Chosen)); + end if; + end if; + end Choose; + + ------------------------ + -- Corresponding_Body -- + ------------------------ + + -- Currently if the body and spec are separate, then they appear as + -- two separate units in the same ALI file, with the body appearing + -- first and the spec appearing second. + + function Corresponding_Body (U : Unit_Id) return Unit_Id is + begin + pragma Assert (Units.Table (U).Utype = Is_Spec); + return U - 1; + end Corresponding_Body; + + ------------------------ + -- Corresponding_Spec -- + ------------------------ + + -- Currently if the body and spec are separate, then they appear as + -- two separate units in the same ALI file, with the body appearing + -- first and the spec appearing second. + + function Corresponding_Spec (U : Unit_Id) return Unit_Id is + begin + pragma Assert (Units.Table (U).Utype = Is_Body); + return U + 1; + end Corresponding_Spec; + + ---------------------------------- + -- Diagnose_Elaboration_Problem -- + ---------------------------------- + + procedure Diagnose_Elaboration_Problem is + + function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean; + -- Recursive routine used to find a path from node Ufrom to node Uto. + -- If a path exists, returns True and outputs an appropriate set of + -- error messages giving the path. Also calls Choose for each of the + -- nodes so that they get removed from the remaining set. There are + -- two cases of calls, either Ufrom = Uto for an attempt to find a + -- cycle, or Ufrom is a spec and Uto the corresponding body for the + -- case of an unsatisfiable Elaborate_Body pragma. ML is the minimum + -- acceptable length for a path. + + --------------- + -- Find_Path -- + --------------- + + function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is + + function Find_Link (U : Unit_Id; PL : Nat) return Boolean; + -- This is the inner recursive routine, it determines if a path + -- exists from U to Uto, and if so returns True and outputs the + -- appropriate set of error messages. PL is the path length + + --------------- + -- Find_Link -- + --------------- + + function Find_Link (U : Unit_Id; PL : Nat) return Boolean is + S : Successor_Id; + + begin + -- Recursion ends if we are at terminating node and the path + -- is sufficiently long, generate error message and return True. + + if U = Uto and then PL >= ML then + Choose (U); + return True; + + -- All done if already visited, otherwise mark as visited + + elsif UNR.Table (U).Visited then + return False; + + -- Otherwise mark as visited and look at all successors + + else + UNR.Table (U).Visited := True; + + S := UNR.Table (U).Successors; + while S /= No_Successor loop + if Find_Link (Succ.Table (S).After, PL + 1) then + Elab_Error_Msg (S); + Choose (U); + return True; + end if; + + S := Succ.Table (S).Next; + end loop; + + -- Falling through means this does not lead to a path + + return False; + end if; + end Find_Link; + + -- Start of processing for Find_Path + + begin + -- Initialize all non-chosen nodes to not visisted yet + + for U in Units.First .. Units.Last loop + UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0; + end loop; + + -- Now try to find the path + + return Find_Link (Ufrom, 0); + end Find_Path; + + -- Start of processing for Diagnose_Elaboration_Error + + begin + Set_Standard_Error; + + -- Output state of things if debug flag N set + + if Debug_Flag_N then + declare + NP : Int; + + begin + Write_Eol; + Write_Eol; + Write_Str ("Diagnose_Elaboration_Problem called"); + Write_Eol; + Write_Str ("List of remaining unchosen units and predecessors"); + Write_Eol; + + for U in Units.First .. Units.Last loop + if UNR.Table (U).Elab_Position = 0 then + NP := UNR.Table (U).Num_Pred; + Write_Eol; + Write_Str (" Unchosen unit: #"); + Write_Int (Int (U)); + Write_Str (" "); + Write_Unit_Name (Units.Table (U).Uname); + Write_Str (" (Num_Pred = "); + Write_Int (NP); + Write_Char (')'); + Write_Eol; + + if NP = 0 then + if Units.Table (U).Elaborate_Body then + Write_Str + (" (not chosen because of Elaborate_Body)"); + Write_Eol; + else + Write_Str (" ****************** why not chosen?"); + Write_Eol; + end if; + end if; + + -- Search links list to find unchosen predecessors + + for S in Succ.First .. Succ.Last loop + declare + SL : Successor_Link renames Succ.Table (S); + + begin + if SL.After = U + and then UNR.Table (SL.Before).Elab_Position = 0 + then + Write_Str (" unchosen predecessor: #"); + Write_Int (Int (SL.Before)); + Write_Str (" "); + Write_Unit_Name (Units.Table (SL.Before).Uname); + Write_Eol; + NP := NP - 1; + end if; + end; + end loop; + + if NP /= 0 then + Write_Str (" **************** Num_Pred value wrong!"); + Write_Eol; + end if; + end if; + end loop; + end; + end if; + + -- Output the header for the error, and manually increment the + -- error count. We are using Error_Msg_Output rather than Error_Msg + -- here for two reasons: + + -- This is really only one error, not one for each line + -- We want this output on standard output since it is voluminous + + -- But we do need to deal with the error count manually in this case + + Errors_Detected := Errors_Detected + 1; + Error_Msg_Output ("elaboration circularity detected", Info => False); + + -- Try to find cycles starting with any of the remaining nodes that have + -- not yet been chosen. There must be at least one (there is some reason + -- we are being called). + + for U in Units.First .. Units.Last loop + if UNR.Table (U).Elab_Position = 0 then + if Find_Path (U, U, 1) then + raise Unrecoverable_Error; + end if; + end if; + end loop; + + -- We should never get here, since we were called for some reason, + -- and we should have found and eliminated at least one bad path. + + raise Program_Error; + end Diagnose_Elaboration_Problem; + + -------------------- + -- Elab_All_Links -- + -------------------- + + procedure Elab_All_Links + (Before : Unit_Id; + After : Unit_Id; + Reason : Succ_Reason; + Link : Elab_All_Id) + is + begin + if UNR.Table (Before).Visited then + return; + end if; + + -- Build the direct link for Before + + UNR.Table (Before).Visited := True; + Build_Link (Before, After, Reason, Link); + + -- Process all units with'ed by Before recursively + + for W in + Units.Table (Before).First_With .. Units.Table (Before).Last_With + loop + -- Skip if this with is an interface to a stand-alone library. + -- Skip also if no ALI file for this WITH, happens for language + -- defined generics while bootstrapping the compiler (see body of + -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited + -- with clause, which does not impose an elaboration link. + + if not Withs.Table (W).SAL_Interface + and then Withs.Table (W).Afile /= No_File + and then not Withs.Table (W).Limited_With + then + declare + Info : constant Int := + Get_Name_Table_Info (Withs.Table (W).Uname); + + begin + -- If the unit is unknown, for some unknown reason, fail + -- graciously explaining that the unit is unknown. Without + -- this check, gnatbind will crash in Unit_Id_Of. + + if Info = 0 or else Unit_Id (Info) = No_Unit_Id then + declare + Withed : String := + Get_Name_String (Withs.Table (W).Uname); + Last_Withed : Natural := Withed'Last; + Withing : String := + Get_Name_String (Units.Table (Before).Uname); + Last_Withing : Natural := Withing'Last; + Spec_Body : String := " (Spec)"; + + begin + To_Mixed (Withed); + To_Mixed (Withing); + + if Last_Withed > 2 and then + Withed (Last_Withed - 1) = '%' + then + Last_Withed := Last_Withed - 2; + end if; + + if Last_Withing > 2 and then + Withing (Last_Withing - 1) = '%' + then + Last_Withing := Last_Withing - 2; + end if; + + if Units.Table (Before).Utype = Is_Body or else + Units.Table (Before).Utype = Is_Body_Only + then + Spec_Body := " (Body)"; + end if; + + Osint.Fail + ("could not find unit " + & Withed (Withed'First .. Last_Withed) & " needed by " + & Withing (Withing'First .. Last_Withing) & Spec_Body); + end; + end if; + + Elab_All_Links + (Unit_Id_Of (Withs.Table (W).Uname), + After, + Reason, + Make_Elab_Entry (Withs.Table (W).Uname, Link)); + end; + end if; + end loop; + + -- Process corresponding body, if there is one + + if Units.Table (Before).Utype = Is_Spec then + Elab_All_Links + (Corresponding_Body (Before), + After, Reason, + Make_Elab_Entry + (Units.Table (Corresponding_Body (Before)).Uname, Link)); + end if; + end Elab_All_Links; + + -------------------- + -- Elab_Error_Msg -- + -------------------- + + procedure Elab_Error_Msg (S : Successor_Id) is + SL : Successor_Link renames Succ.Table (S); + + begin + -- Nothing to do if internal unit involved and no -da flag + + if not Debug_Flag_A + and then + (Is_Internal_File_Name (Units.Table (SL.Before).Sfile) + or else + Is_Internal_File_Name (Units.Table (SL.After).Sfile)) + then + return; + end if; + + -- Here we want to generate output + + Error_Msg_Unit_1 := Units.Table (SL.Before).Uname; + + if SL.Elab_Body then + Error_Msg_Unit_2 := Units.Table (Corresponding_Body (SL.After)).Uname; + else + Error_Msg_Unit_2 := Units.Table (SL.After).Uname; + end if; + + Error_Msg_Output (" $ must be elaborated before $", Info => True); + + Error_Msg_Unit_1 := Units.Table (SL.Reason_Unit).Uname; + + case SL.Reason is + when Withed => + Error_Msg_Output + (" reason: with clause", + Info => True); + + when Elab => + Error_Msg_Output + (" reason: pragma Elaborate in unit $", + Info => True); + + when Elab_All => + Error_Msg_Output + (" reason: pragma Elaborate_All in unit $", + Info => True); + + when Elab_All_Desirable => + Error_Msg_Output + (" reason: implicit Elaborate_All in unit $", + Info => True); + + Error_Msg_Output + (" recompile $ with -gnatel for full details", + Info => True); + + when Elab_Desirable => + Error_Msg_Output + (" reason: implicit Elaborate in unit $", + Info => True); + + Error_Msg_Output + (" recompile $ with -gnatel for full details", + Info => True); + + when Spec_First => + Error_Msg_Output + (" reason: spec always elaborated before body", + Info => True); + end case; + + Write_Elab_All_Chain (S); + + if SL.Elab_Body then + Error_Msg_Unit_1 := Units.Table (SL.Before).Uname; + Error_Msg_Unit_2 := Units.Table (SL.After).Uname; + Error_Msg_Output + (" $ must therefore be elaborated before $", + True); + + Error_Msg_Unit_1 := Units.Table (SL.After).Uname; + Error_Msg_Output + (" (because $ has a pragma Elaborate_Body)", + True); + end if; + + if not Zero_Formatting then + Write_Eol; + end if; + end Elab_Error_Msg; + + --------------------- + -- Find_Elab_Order -- + --------------------- + + procedure Find_Elab_Order is + U : Unit_Id; + Best_So_Far : Unit_Id; + + begin + Succ.Init; + Num_Left := Int (Units.Last - Units.First + 1); + + -- Initialize unit table for elaboration control + + for U in Units.First .. Units.Last loop + UNR.Increment_Last; + UNR.Table (UNR.Last).Successors := No_Successor; + UNR.Table (UNR.Last).Num_Pred := 0; + UNR.Table (UNR.Last).Nextnp := No_Unit_Id; + UNR.Table (UNR.Last).Elab_Order := 0; + UNR.Table (UNR.Last).Elab_Position := 0; + end loop; + + -- Output warning if -p used with no -gnatE units + + if Pessimistic_Elab_Order + and not Dynamic_Elaboration_Checks_Specified + then + if OpenVMS_On_Target then + Error_Msg ("?use of /PESSIMISTIC_ELABORATION questionable"); + else + Error_Msg ("?use of -p switch questionable"); + end if; + + Error_Msg ("?since all units compiled with static elaboration model"); + end if; + + -- Gather dependencies and output them if option set + + Gather_Dependencies; + + -- Output elaboration dependencies if option is set + + if Elab_Dependency_Output or Debug_Flag_E then + Write_Dependencies; + end if; + + -- Initialize the no predecessor list + + No_Pred := No_Unit_Id; + + for U in UNR.First .. UNR.Last loop + if UNR.Table (U).Num_Pred = 0 then + UNR.Table (U).Nextnp := No_Pred; + No_Pred := U; + end if; + end loop; + + -- OK, now we determine the elaboration order proper. All we do is to + -- select the best choice from the no predecessor list until all the + -- nodes have been chosen. + + Outer : loop + + -- If there are no nodes with predecessors, then either we are + -- done, as indicated by Num_Left being set to zero, or we have + -- a circularity. In the latter case, diagnose the circularity, + -- removing it from the graph and continue + + Get_No_Pred : while No_Pred = No_Unit_Id loop + exit Outer when Num_Left < 1; + Diagnose_Elaboration_Problem; + end loop Get_No_Pred; + + U := No_Pred; + Best_So_Far := No_Unit_Id; + + -- Loop to choose best entry in No_Pred list + + No_Pred_Search : loop + if Debug_Flag_N then + Write_Str (" considering choice of "); + Write_Unit_Name (Units.Table (U).Uname); + Write_Eol; + + if Units.Table (U).Elaborate_Body then + Write_Str + (" Elaborate_Body = True, Num_Pred for body = "); + Write_Int + (UNR.Table (Corresponding_Body (U)).Num_Pred); + else + Write_Str + (" Elaborate_Body = False"); + end if; + + Write_Eol; + end if; + + -- This is a candididate to be considered for choice + + if Best_So_Far = No_Unit_Id + or else ((not Pessimistic_Elab_Order) + and then Better_Choice (U, Best_So_Far)) + or else (Pessimistic_Elab_Order + and then Pessimistic_Better_Choice (U, Best_So_Far)) + then + if Debug_Flag_N then + Write_Str (" tentatively chosen (best so far)"); + Write_Eol; + end if; + + Best_So_Far := U; + end if; + + U := UNR.Table (U).Nextnp; + exit No_Pred_Search when U = No_Unit_Id; + end loop No_Pred_Search; + + -- If no candididate chosen, it means that no unit has No_Pred = 0, + -- but there are units left, hence we have a circular dependency, + -- which we will get Diagnose_Elaboration_Problem to diagnose it. + + if Best_So_Far = No_Unit_Id then + Diagnose_Elaboration_Problem; + + -- Otherwise choose the best candidate found + + else + Choose (Best_So_Far); + end if; + end loop Outer; + end Find_Elab_Order; + + ------------------------- + -- Gather_Dependencies -- + ------------------------- + + procedure Gather_Dependencies is + Withed_Unit : Unit_Id; + + begin + -- Loop through all units + + for U in Units.First .. Units.Last loop + Cur_Unit := U; + + -- If this is not an interface to a stand-alone library and + -- there is a body and a spec, then spec must be elaborated first + -- Note that the corresponding spec immediately follows the body + + if not Units.Table (U).SAL_Interface + and then Units.Table (U).Utype = Is_Body + then + Build_Link (Corresponding_Spec (U), U, Spec_First); + end if; + + -- If this unit is not an interface to a stand-alone library, + -- process WITH references for this unit ignoring generic units and + -- interfaces to stand-alone libraries. + + if not Units.Table (U).SAL_Interface then + for + W in Units.Table (U).First_With .. Units.Table (U).Last_With + loop + if Withs.Table (W).Sfile /= No_File + and then (not Withs.Table (W).SAL_Interface) + then + -- Check for special case of withing a unit that does not + -- exist any more. If the unit was completely missing we + -- would already have detected this, but a nasty case arises + -- when we have a subprogram body with no spec, and some + -- obsolete unit with's a previous (now disappeared) spec. + + if Get_Name_Table_Info (Withs.Table (W).Uname) = 0 then + Error_Msg_File_1 := Units.Table (U).Sfile; + Error_Msg_Unit_1 := Withs.Table (W).Uname; + Error_Msg ("{ depends on $ which no longer exists"); + goto Next_With; + end if; + + Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname); + + -- Pragma Elaborate_All case, for this we use the recursive + -- Elab_All_Links procedure to establish the links. + + if Withs.Table (W).Elaborate_All then + + -- Reset flags used to stop multiple visits to a given + -- node. + + for Uref in UNR.First .. UNR.Last loop + UNR.Table (Uref).Visited := False; + end loop; + + -- Now establish all the links we need + + Elab_All_Links + (Withed_Unit, U, Elab_All, + Make_Elab_Entry + (Withs.Table (W).Uname, No_Elab_All_Link)); + + -- Elaborate_All_Desirable case, for this we establish the + -- same links as above, but with a different reason. + + elsif Withs.Table (W).Elab_All_Desirable then + + -- Reset flags used to stop multiple visits to a given + -- node. + + for Uref in UNR.First .. UNR.Last loop + UNR.Table (Uref).Visited := False; + end loop; + + -- Now establish all the links we need + + Elab_All_Links + (Withed_Unit, U, Elab_All_Desirable, + Make_Elab_Entry + (Withs.Table (W).Uname, No_Elab_All_Link)); + + -- Pragma Elaborate case. We must build a link for the + -- withed unit itself, and also the corresponding body if + -- there is one. + + -- However, skip this processing if there is no ALI file for + -- the WITH entry, because this means it is a generic (even + -- when we fix the generics so that an ALI file is present, + -- we probably still will have no ALI file for unchecked and + -- other special cases). + + elsif Withs.Table (W).Elaborate + and then Withs.Table (W).Afile /= No_File + then + Build_Link (Withed_Unit, U, Withed); + + if Units.Table (Withed_Unit).Utype = Is_Spec then + Build_Link + (Corresponding_Body (Withed_Unit), U, Elab); + end if; + + -- Elaborate_Desirable case, for this we establish + -- the same links as above, but with a different reason. + + elsif Withs.Table (W).Elab_Desirable then + Build_Link (Withed_Unit, U, Withed); + + if Units.Table (Withed_Unit).Utype = Is_Spec then + Build_Link + (Corresponding_Body (Withed_Unit), + U, Elab_Desirable); + end if; + + -- A limited_with does not establish an elaboration + -- dependence (that's the whole point).. + + elsif Withs.Table (W).Limited_With then + null; + + -- Case of normal WITH with no elaboration pragmas, just + -- build the single link to the directly referenced unit + + else + Build_Link (Withed_Unit, U, Withed); + end if; + end if; + + <> + null; + end loop; + end if; + end loop; + end Gather_Dependencies; + + ------------------ + -- Is_Body_Unit -- + ------------------ + + function Is_Body_Unit (U : Unit_Id) return Boolean is + begin + return Units.Table (U).Utype = Is_Body + or else Units.Table (U).Utype = Is_Body_Only; + end Is_Body_Unit; + + ----------------------------- + -- Is_Pure_Or_Preelab_Unit -- + ----------------------------- + + function Is_Pure_Or_Preelab_Unit (U : Unit_Id) return Boolean is + begin + -- If we have a body with separate spec, test flags on the spec + + if Units.Table (U).Utype = Is_Body then + return Units.Table (U + 1).Preelab + or else + Units.Table (U + 1).Pure; + + -- Otherwise we have a spec or body acting as spec, test flags on unit + + else + return Units.Table (U).Preelab + or else + Units.Table (U).Pure; + end if; + end Is_Pure_Or_Preelab_Unit; + + --------------------- + -- Is_Waiting_Body -- + --------------------- + + function Is_Waiting_Body (U : Unit_Id) return Boolean is + begin + return Units.Table (U).Utype = Is_Body + and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0; + end Is_Waiting_Body; + + --------------------- + -- Make_Elab_Entry -- + --------------------- + + function Make_Elab_Entry + (Unam : Unit_Name_Type; + Link : Elab_All_Id) return Elab_All_Id + is + begin + Elab_All_Entries.Increment_Last; + Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam; + Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link; + return Elab_All_Entries.Last; + end Make_Elab_Entry; + + ------------------------------- + -- Pessimistic_Better_Choice -- + ------------------------------- + + function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean is + UT1 : Unit_Record renames Units.Table (U1); + UT2 : Unit_Record renames Units.Table (U2); + + begin + if Debug_Flag_B then + Write_Str ("Pessimistic_Better_Choice ("); + Write_Unit_Name (UT1.Uname); + Write_Str (", "); + Write_Unit_Name (UT2.Uname); + Write_Line (")"); + end if; + + -- Note: the checks here are applied in sequence, and the ordering is + -- significant (i.e. the more important criteria are applied first). + + -- If either unit is predefined or internal, then we use the normal + -- Better_Choice rule, since we don't want to disturb the elaboration + -- rules of the language with -p, same treatment for Pure/Preelab. + + -- Prefer a predefined unit to a non-predefined unit + + if UT1.Predefined and then not UT2.Predefined then + if Debug_Flag_B then + Write_Line (" True: u1 is predefined, u2 is not"); + end if; + + return True; + + elsif UT2.Predefined and then not UT1.Predefined then + if Debug_Flag_B then + Write_Line (" False: u2 is predefined, u1 is not"); + end if; + + return False; + + -- Prefer an internal unit to a non-internal unit + + elsif UT1.Internal and then not UT2.Internal then + if Debug_Flag_B then + Write_Line (" True: u1 is internal, u2 is not"); + end if; + + return True; + + elsif UT2.Internal and then not UT1.Internal then + if Debug_Flag_B then + Write_Line (" False: u2 is internal, u1 is not"); + end if; + + return False; + + -- Prefer a pure or preelaborable unit to one that is not + + elsif Is_Pure_Or_Preelab_Unit (U1) + and then not + Is_Pure_Or_Preelab_Unit (U2) + then + if Debug_Flag_B then + Write_Line (" True: u1 is pure/preelab, u2 is not"); + end if; + + return True; + + elsif Is_Pure_Or_Preelab_Unit (U2) + and then not + Is_Pure_Or_Preelab_Unit (U1) + then + if Debug_Flag_B then + Write_Line (" False: u2 is pure/preelab, u1 is not"); + end if; + + return False; + + -- Prefer anything else to a waiting body. We want to make bodies wait + -- as long as possible, till we are forced to choose them. + + elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then + if Debug_Flag_B then + Write_Line (" False: u1 is waiting body, u2 is not"); + end if; + + return False; + + elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then + if Debug_Flag_B then + Write_Line (" True: u2 is waiting body, u1 is not"); + end if; + + return True; + + -- Prefer a spec to a body (this is mandatory) + + elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then + if Debug_Flag_B then + Write_Line (" False: u1 is body, u2 is not"); + end if; + + return False; + + elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then + if Debug_Flag_B then + Write_Line (" True: u2 is body, u1 is not"); + end if; + + return True; + + -- If both are waiting bodies, then prefer the one whose spec is + -- less recently elaborated. Consider the following: + + -- spec of A + -- spec of B + -- body of A or B? + + -- The normal waiting body preference would have placed the body of + -- A before the spec of B if it could. Since it could not, there it + -- must be the case that A depends on B. It is therefore a good idea + -- to put the body of B last so that if there is an elaboration order + -- problem, we will find it (that's what pessimistic order is about) + + elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then + declare + Result : constant Boolean := + UNR.Table (Corresponding_Spec (U1)).Elab_Position < + UNR.Table (Corresponding_Spec (U2)).Elab_Position; + begin + if Debug_Flag_B then + if Result then + Write_Line (" True: based on waiting body elab positions"); + else + Write_Line (" False: based on waiting body elab positions"); + end if; + end if; + + return Result; + end; + end if; + + -- Remaining choice rules are disabled by Debug flag -do + + if not Debug_Flag_O then + + -- The following deal with the case of specs which have been marked + -- as Elaborate_Body_Desirable. In the normal case, we generally want + -- to delay the elaboration of these specs as long as possible, so + -- that bodies have better chance of being elaborated closer to the + -- specs. Pessimistic_Better_Choice as usual wants to do the opposite + -- and elaborate such specs as early as possible. + + -- If we have two units, one of which is a spec for which this flag + -- is set, and the other is not, we normally prefer to delay the spec + -- for which the flag is set, so again Pessimistic_Better_Choice does + -- the opposite. + + if not UT1.Elaborate_Body_Desirable + and then UT2.Elaborate_Body_Desirable + then + if Debug_Flag_B then + Write_Line (" False: u1 is elab body desirable, u2 is not"); + end if; + + return False; + + elsif not UT2.Elaborate_Body_Desirable + and then UT1.Elaborate_Body_Desirable + then + if Debug_Flag_B then + Write_Line (" True: u1 is elab body desirable, u2 is not"); + end if; + + return True; + + -- If we have two specs that are both marked as Elaborate_Body + -- desirable, we normally prefer the one whose body is nearer to + -- being able to be elaborated, based on the Num_Pred count. This + -- helps to ensure bodies are as close to specs as possible. As + -- usual, Pessimistic_Better_Choice does the opposite. + + elsif UT1.Elaborate_Body_Desirable + and then UT2.Elaborate_Body_Desirable + then + declare + Result : constant Boolean := + UNR.Table (Corresponding_Body (U1)).Num_Pred >= + UNR.Table (Corresponding_Body (U2)).Num_Pred; + begin + if Debug_Flag_B then + if Result then + Write_Line (" True based on Num_Pred compare"); + else + Write_Line (" False based on Num_Pred compare"); + end if; + end if; + + return Result; + end; + end if; + end if; + + -- If we fall through, it means that no preference rule applies, so we + -- use alphabetical order to at least give a deterministic result. Since + -- Pessimistic_Better_Choice is in the business of stirring up the + -- order, we will use reverse alphabetical ordering. + + if Debug_Flag_B then + Write_Line (" choose on reverse alpha order"); + end if; + + return Uname_Less (UT2.Uname, UT1.Uname); + end Pessimistic_Better_Choice; + + ---------------- + -- Unit_Id_Of -- + ---------------- + + function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is + Info : constant Int := Get_Name_Table_Info (Uname); + begin + pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); + return Unit_Id (Info); + end Unit_Id_Of; + + ------------------------ + -- Write_Dependencies -- + ------------------------ + + procedure Write_Dependencies is + begin + if not Zero_Formatting then + Write_Eol; + Write_Str (" ELABORATION ORDER DEPENDENCIES"); + Write_Eol; + Write_Eol; + end if; + + Info_Prefix_Suppress := True; + + for S in Succ_First .. Succ.Last loop + Elab_Error_Msg (S); + end loop; + + Info_Prefix_Suppress := False; + + if not Zero_Formatting then + Write_Eol; + end if; + end Write_Dependencies; + + -------------------------- + -- Write_Elab_All_Chain -- + -------------------------- + + procedure Write_Elab_All_Chain (S : Successor_Id) is + ST : constant Successor_Link := Succ.Table (S); + After : constant Unit_Name_Type := Units.Table (ST.After).Uname; + + L : Elab_All_Id; + Nam : Unit_Name_Type; + + First_Name : Boolean := True; + + begin + if ST.Reason in Elab_All .. Elab_All_Desirable then + L := ST.Elab_All_Link; + while L /= No_Elab_All_Link loop + Nam := Elab_All_Entries.Table (L).Needed_By; + Error_Msg_Unit_1 := Nam; + Error_Msg_Output (" $", Info => True); + + Get_Name_String (Nam); + + if Name_Buffer (Name_Len) = 'b' then + if First_Name then + Error_Msg_Output + (" must be elaborated along with its spec:", + Info => True); + + else + Error_Msg_Output + (" which must be elaborated " & + "along with its spec:", + Info => True); + end if; + + else + if First_Name then + Error_Msg_Output + (" is withed by:", + Info => True); + + else + Error_Msg_Output + (" which is withed by:", + Info => True); + end if; + end if; + + First_Name := False; + + L := Elab_All_Entries.Table (L).Next_Elab; + end loop; + + Error_Msg_Unit_1 := After; + Error_Msg_Output (" $", Info => True); + end if; + end Write_Elab_All_Chain; + +end Binde; -- cgit v1.2.3