URL
https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk
Subversion Repositories openrisc_me
[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [binde.adb] - Rev 281
Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B I N D E -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2009, 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_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 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. function Worse_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 -h (horrible -- elaboration order) switch. We still have to obey Ada rules, so it is -- not quite the direct inverse of Better_Choice. 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 any other case 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 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 (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 -gnatwl for full details", Info => True); when Elab_Desirable => Error_Msg_Output (" reason: implicit Elaborate in unit $", Info => True); Error_Msg_Output (" recompile $ with -gnatwl 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 (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 Worse_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 (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; <<Next_With>> 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_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; ---------------- -- 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; ------------------ -- Worse_Choice -- ------------------ function Worse_Choice (U1, U2 : Unit_Id) return Boolean is UT1 : Unit_Record renames Units.Table (U1); UT2 : Unit_Record renames Units.Table (U2); begin -- 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 internal, then use Better_Choice, since the -- language requires that predefined units not mess up in the choice -- of elaboration order, and for internal units, any problems are -- ours and not the programmers. if UT1.Internal or else UT2.Internal then return Better_Choice (U1, U2); -- Prefer anything else to a waiting body (!) elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then return False; elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then return True; -- Prefer a spec to a body (!) elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then return False; elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then 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 horrible order is about) elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then return UNR.Table (Corresponding_Spec (U1)).Elab_Position < UNR.Table (Corresponding_Spec (U2)).Elab_Position; 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. Worse_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, and so Worse_Choice does the opposite. if not UT1.Elaborate_Body_Desirable and then UT2.Elaborate_Body_Desirable then return False; elsif not UT2.Elaborate_Body_Desirable and then UT1.Elaborate_Body_Desirable then 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, Worse_Choice does the opposite. elsif UT1.Elaborate_Body_Desirable and then UT2.Elaborate_Body_Desirable then return UNR.Table (Corresponding_Body (U1)).Num_Pred >= UNR.Table (Corresponding_Body (U2)).Num_Pred; 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 -- Worse_Choice is in the business of stirring up the order, we will -- use reverse alphabetical ordering. return Uname_Less (UT2.Uname, UT1.Uname); end Worse_Choice; ------------------------ -- 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;