| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- B I N D E -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2005, 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 2, 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 COPYING. If not, write -- |
| -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- |
| -- Boston, MA 02110-1301, USA. -- |
| -- -- |
| -- 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 Lib; use Lib; |
| with Namet; use Namet; |
| with Opt; use Opt; |
| with Output; use Output; |
| with Targparm; use Targparm; |
| |
| 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 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 |
| |
| function Body_Unit (U : Unit_Id) return Boolean; |
| -- Determines if given unit is a body |
| |
| function Waiting_Body (U : Unit_Id) return Boolean; |
| -- Determines if U is a waiting body, defined as a body which has |
| -- not been elaborated, but whose spec has been elaborated. |
| |
| function 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 Body_Unit; |
| |
| function 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 Waiting_Body; |
| |
| -- Start of processing for Better_Choice |
| |
| -- Note: the checks here are applied in sequence, and the ordering is |
| -- significant (i.e. the more important criteria are applied first). |
| |
| begin |
| -- Prefer a waiting body to any other case |
| |
| if Waiting_Body (U1) and not Waiting_Body (U2) then |
| return True; |
| |
| elsif Waiting_Body (U2) and not Waiting_Body (U1) then |
| return False; |
| |
| -- Prefer a predefined unit to a non-predefined unit |
| |
| elsif Units.Table (U1).Predefined |
| and not Units.Table (U2).Predefined |
| then |
| return True; |
| |
| elsif Units.Table (U2).Predefined |
| and not Units.Table (U1).Predefined |
| then |
| return False; |
| |
| -- Prefer an internal unit to a non-internal unit |
| |
| elsif Units.Table (U1).Internal |
| and not Units.Table (U2).Internal |
| then |
| return True; |
| |
| elsif Units.Table (U2).Internal |
| and not Units.Table (U1).Internal |
| then |
| return False; |
| |
| -- Prefer a body to a spec |
| |
| elsif Body_Unit (U1) and not Body_Unit (U2) then |
| return True; |
| |
| elsif Body_Unit (U2) and not Body_Unit (U1) then |
| 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 Waiting_Body (U1) and then Waiting_Body (U2) then |
| return |
| UNR.Table (Corresponding_Spec (U1)).Elab_Position > |
| UNR.Table (Corresponding_Spec (U2)).Elab_Position; |
| |
| -- Otherwise decide on the basis of alphabetical order |
| |
| else |
| return Uname_Less (Units.Table (U1).Uname, Units.Table (U2).Uname); |
| end if; |
| 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 with certain |
| -- specialized generic files that do not get compiled. |
| |
| if not Withs.Table (W).SAL_Interface |
| and then Withs.Table (W).Afile /= No_File |
| and then Generic_Separately_Compiled (Withs.Table (W).Sfile) |
| then |
| Elab_All_Links |
| (Unit_Id_Of (Withs.Table (W).Uname), |
| After, |
| Reason, |
| Make_Elab_Entry (Withs.Table (W).Uname, Link)); |
| 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_Name_1 := Units.Table (SL.Before).Uname; |
| |
| if SL.Elab_Body then |
| Error_Msg_Name_2 := Units.Table (Corresponding_Body (SL.After)).Uname; |
| else |
| Error_Msg_Name_2 := Units.Table (SL.After).Uname; |
| end if; |
| |
| Error_Msg_Output (" & must be elaborated before &", Info => True); |
| |
| Error_Msg_Name_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_Name_1 := Units.Table (SL.Before).Uname; |
| Error_Msg_Name_2 := Units.Table (SL.After).Uname; |
| Error_Msg_Output |
| (" & must therefore be elaborated before &", |
| True); |
| |
| Error_Msg_Name_1 := Units.Table (SL.After).Uname; |
| Error_Msg_Output |
| (" (because & has a pragma Elaborate_Body)", |
| True); |
| end if; |
| |
| Write_Eol; |
| 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_Name_1 := Units.Table (U).Sfile; |
| Error_Msg_Name_2 := 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; |
| |
| -- 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; |
| |
| --------------------- |
| -- 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 |
| |
| function Body_Unit (U : Unit_Id) return Boolean; |
| -- Determines if given unit is a body |
| |
| function Waiting_Body (U : Unit_Id) return Boolean; |
| -- Determines if U is a waiting body, defined as a body which has |
| -- not been elaborated, but whose spec has been elaborated. |
| |
| --------------- |
| -- Body_Unit -- |
| --------------- |
| |
| function 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 Body_Unit; |
| |
| ------------------ |
| -- Waiting_Body -- |
| ------------------ |
| |
| function 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 Waiting_Body; |
| |
| -- Start of processing for Worse_Choice |
| |
| 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 Units.Table (U1).Internal or else Units.Table (U2).Internal then |
| return Better_Choice (U1, U2); |
| |
| -- Prefer anything else to a waiting body (!) |
| |
| elsif Waiting_Body (U1) and not Waiting_Body (U2) then |
| return False; |
| |
| elsif Waiting_Body (U2) and not Waiting_Body (U1) then |
| return True; |
| |
| -- Prefer a spec to a body (!) |
| |
| elsif Body_Unit (U1) and not Body_Unit (U2) then |
| return False; |
| |
| elsif Body_Unit (U2) and not 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 Waiting_Body (U1) and then Waiting_Body (U2) then |
| return |
| UNR.Table (Corresponding_Spec (U1)).Elab_Position < |
| UNR.Table (Corresponding_Spec (U2)).Elab_Position; |
| |
| -- Otherwise decide on the basis of alphabetical order. We do not try |
| -- to reverse the usual choice here, since it can cause cancelling |
| -- errors with the other inversions. |
| |
| else |
| return Uname_Less (Units.Table (U1).Uname, Units.Table (U2).Uname); |
| end if; |
| end Worse_Choice; |
| |
| ------------------------ |
| -- Write_Dependencies -- |
| ------------------------ |
| |
| procedure Write_Dependencies is |
| begin |
| Write_Eol; |
| Write_Str |
| (" ELABORATION ORDER DEPENDENCIES"); |
| Write_Eol; |
| Write_Eol; |
| |
| Info_Prefix_Suppress := True; |
| |
| for S in Succ_First .. Succ.Last loop |
| Elab_Error_Msg (S); |
| end loop; |
| |
| Info_Prefix_Suppress := False; |
| Write_Eol; |
| 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_Name_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_Name_1 := After; |
| Error_Msg_Output (" &", Info => True); |
| end if; |
| end Write_Elab_All_Chain; |
| |
| end Binde; |
