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 Table;
with System.Case_Util; use System.Case_Util;
with System.OS_Lib;
package body Binde is
+ -- We now have Elab_New, a new elaboration-order algorithm. It has the
+ -- property that ???
+ --
+ -- However, any change to elaboration order can break some programs.
+ -- Therefore, we are keeping the old algorithm in place, to be selected
+ -- by switches.
+ --
+ -- The new algorithm has the following interesting properties:
+ --
+ -- * The static and dynamic models use the same elaboration order. The
+ -- static model might get an error, but if it does not, it will use
+ -- the same order as the dynamic model.
+ --
+ -- * Each SCC (see below) is elaborated together; that is, units from
+ -- different SCCs are not interspersed.
+ --
+ -- * In particular, this implies that if an SCC contains just a spec and
+ -- the corresponding body, and nothing else, the body will be
+ -- elaborated immediately after the spec. This is expected to result
+ -- in a better elaboration order for most programs, because in this
+ -- case, a call from outside the library unit cannot get ABE.
+ --
+ -- * Pragmas Elaborate_All (explicit and implicit) are ignored. Instead,
+ -- we behave as if every legal pragma Elaborate_All were present. That
+ -- is, if it would be legal to have "pragma Elaborate_All(Y);" on X,
+ -- then we behave as if such a pragma exists, even if it does not.
+
+ Do_Old : constant Boolean := False;
+ Do_New : constant Boolean := True;
+ -- True to enable the old and new algorithms, respectively. Used for
+ -- debugging/experimentation.
+
+ Doing_New : Boolean := False;
+ -- True if we are currently doing the new algorithm. Print certain
+ -- messages only when doing the "new" elab order algorithm, so we don't get
+ -- duplicates. And use different heuristics in Better_Choice_Optimistic.
+
-- 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.
+ -- The following structures are used to record successors. If B is a
+ -- successor of A in this table, it means that A must be elaborated before
+ -- B is elaborated. For example, if Y (body) says "with X;", then Y (body)
+ -- will be a successor of X (spec), and X (spec) will be a predecessor of
+ -- Y (body).
+ --
+ -- Note that we store the successors of each unit explictly. We don't store
+ -- the predecessors, but we store a count of them.
+ --
+ -- The basic algorithm is to first compute a directed graph of units (type
+ -- Unit_Node_Record, below), with successors as edges. A unit is "ready"
+ -- (to be chosen as the next to be elaborated) if it has no predecessors
+ -- that have not yet been chosen. We use heuristics to decide which of the
+ -- ready units should be elaborated next, and "choose" that one (which
+ -- means we append it to the elaboration-order table).
type Successor_Id is new Nat;
-- Identification of single successor entry
-- order file.
Elab,
- -- After directly mentions Before in a pragma Elaborate, so the
- -- body of Before must be elaborated before After is elaborated.
+ -- After directly mentions Before in a pragma Elaborate, so the body of
+ -- Before must be elaborated 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.
+ -- 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".
+ -- 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".
+ -- 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
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
+ -- first element in a list of Elab_All entries that record the with
-- chain resulting in this particular dependency.
-
end record;
-- Note on handling of Elaborate_Body. Basically, if we have a pragma
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");
+ 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
+ -- 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;
-- 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");
+ 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_Id_Array_Ptr is access Unit_Id_Array;
- type Unit_Node_Record is record
+ -- 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).
+ -- Number of predecessors for this unit that have not yet been chosen.
+ -- 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.
+ -- 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.
-
+ -- 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.
+
+ -- The following are for Elab_New. We compute the strongly connected
+ -- components (SCCs) of the directed graph of units. The edges are the
+ -- Successors, which do not include pragmas Elaborate_All (explicit or
+ -- implicit) in Elab_New. In addition, we assume there is a edge
+ -- pointing from a body to its corresponding spec; this edge is not
+ -- included in Successors, because of course a spec is elaborated BEFORE
+ -- its body, not after.
+
+ SCC_Root : Unit_Id;
+ -- Each unit points to the root of its SCC, which is just an arbitrary
+ -- member of the SCC. Two units are in the same SCC if and only if their
+ -- SCC_Roots are equal. U is the root of its SCC if and only if
+ -- SCC(U)=U.
+
+ Nodes : Unit_Id_Array_Ptr;
+ -- Present only in the root of an SCC. This is the set of units in the
+ -- SCC, in no particular order.
+
+ SCC_Num_Pred : Int;
+ -- Present only in the root of an SCC. This is the number of predecessor
+ -- units of the SCC that are in other SCCs, and that have not yet been
+ -- chosen.
+
+ Validate_Seen : Boolean := False;
+ -- See procedure Validate below
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");
+ 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
-- 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.
+ -- 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;
+ Num_Chosen : Natural;
-- Number of units chosen in the elaboration order so far
-----------------------
-- Local Subprograms --
-----------------------
- function Better_Choice (U1, U2 : Unit_Id) return Boolean;
+ function Debug_Flag_Older return Boolean;
+ function Debug_Flag_Old return Boolean;
+ -- True if debug flags select the old or older algorithms
+
+ procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean);
+ -- Assert that certain properties are true
+
+ function Better_Choice_Optimistic
+ (U1 : Unit_Id;
+ 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
-- 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.
+ function Better_Choice_Pessimistic
+ (U1 : Unit_Id;
+ U2 : Unit_Id) return Boolean;
+ -- This is like Better_Choice_Optimistic, 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_Optimistic.
+
+ function Better_Choice (U1 : Unit_Id; U2 : Unit_Id) return Boolean;
+ -- Calls Better_Choice_Optimistic or Better_Choice_Pessimistic as
+ -- appropriate. Also takes care of the U2 = No_Unit_Id case.
+
procedure Build_Link
(Before : Unit_Id;
After : Unit_Id;
-- 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);
+ procedure Choose (Elab_Order : in out Unit_Id_Table; Chosen : Unit_Id);
-- Chosen is the next entry chosen in the elaboration order. This procedure
-- updates all data structures appropriately.
-- the unit id of the spec. It is an error to call this routine with a unit
-- that is not a body, or that does not have a separate spec.
- procedure Diagnose_Elaboration_Problem;
+ procedure Diagnose_Elaboration_Problem
+ (Elab_Order : in out Unit_Id_Table);
-- Called when no elaboration order can be found. Outputs an appropriate
-- diagnosis of the problem, and then abandons the bind.
procedure Gather_Dependencies;
-- Compute dependencies, building the Succ and UNR tables
+ procedure Init;
+ -- Initialize global data structures in this package body
+
function Is_Body_Unit (U : Unit_Id) return Boolean;
pragma Inline (Is_Body_Unit);
-- Determines if given unit is a body
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_Closure (Order : Unit_Id_Array);
+ -- Write the closure. This is for the -R and -Ra switches, "list closure
+ -- display".
+
procedure Write_Dependencies;
-- Write out dependencies (called only if appropriate option is set)
-- If the reason for the link S is Elaborate_All or Elaborate_Desirable,
-- then this routine will output the "needed by" explanation chain.
+ procedure Write_Elab_Order (Order : Unit_Id_Array; Title : String);
+ -- Display elaboration order. This is for the -l switch. Title is a heading
+ -- to print; an empty string is passed to indicate Zero_Formatting.
+
+ package Elab_New is
+
+ -- Implementation of the new algorithm
+
+ procedure Write_SCC (U : Unit_Id);
+ -- Write the unit names of the units in the SCC in which U lives
+
+ procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table);
+
+ Illegal_Elab_All : Boolean := False;
+ -- Set true if Find_Elab_Order found an illegal pragma Elaborate_All
+ -- (explicit or implicit).
+
+ function SCC (U : Unit_Id) return Unit_Id;
+ -- The root of the strongly connected component containing U
+
+ function SCC_Num_Pred (U : Unit_Id) return Int;
+ -- The SCC_Num_Pred of the SCC in which U lives
+
+ function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr;
+ -- The nodes of the strongly connected component containing U
+
+ end Elab_New;
+
+ use Elab_New;
+
+ package Elab_Old is
+
+ -- Implementation of the old algorithm
+
+ procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table);
+
+ end Elab_Old;
+
+ -- Most of the code is shared between old and new; such code is outside
+ -- packages Elab_Old and Elab_New.
+
-------------------
-- Better_Choice --
-------------------
- function Better_Choice (U1, U2 : Unit_Id) return Boolean is
+ function Better_Choice (U1 : Unit_Id; U2 : Unit_Id) return Boolean is
+ pragma Assert (U1 /= No_Unit_Id);
+ begin
+ if U2 = No_Unit_Id then
+ return True;
+ end if;
+
+ if Pessimistic_Elab_Order then
+ return Better_Choice_Pessimistic (U1, U2);
+ else
+ return Better_Choice_Optimistic (U1, U2);
+ end if;
+ end Better_Choice;
+
+ ------------------------------
+ -- Better_Choice_Optimistic --
+ ------------------------------
+
+ function Better_Choice_Optimistic
+ (U1 : Unit_Id;
+ 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_Str ("Better_Choice_Optimistic (");
Write_Unit_Name (UT1.Uname);
Write_Str (", ");
Write_Unit_Name (UT2.Uname);
return False;
- -- Prefer a pure or preelaborable unit to one that is not
+ -- Prefer a pure or preelaborated unit to one that is not Pure should
+ -- come before preelaborated.
elsif Is_Pure_Or_Preelab_Unit (U1)
and then not
return False;
- -- If both are waiting bodies, then prefer the one whose spec is
- -- more recently elaborated. Consider the following:
+ -- 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, then it
- -- must be the case that A depends on B. It is therefore a good idea
- -- to put the body of B first.
+ -- The normal waiting body preference would have placed the body of A
+ -- before the spec of B if it could. Since it could not, then 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;
+ UNR.Table (Corresponding_Spec (U1)).Elab_Position >
+ UNR.Table (Corresponding_Spec (U2)).Elab_Position;
begin
if Debug_Flag_B then
if Result then
-- Remaining choice rules are disabled by Debug flag -do
- if not Debug_Flag_O then
+ if not Debug_Flag_Older then
-- The following deal with the case of specs that have been marked
-- as Elaborate_Body_Desirable. We generally want to delay these
then
declare
Result : constant Boolean :=
- UNR.Table (Corresponding_Body (U1)).Num_Pred <
- UNR.Table (Corresponding_Body (U2)).Num_Pred;
+ UNR.Table (Corresponding_Body (U1)).Num_Pred <
+ UNR.Table (Corresponding_Body (U2)).Num_Pred;
begin
if Debug_Flag_B then
if Result then
end if;
end if;
+ -- If we have two specs in the same SCC, choose the one whose body is
+ -- closer to being ready.
+
+ if Doing_New
+ and then SCC (U1) = SCC (U2)
+ and then Units.Table (U1).Utype = Is_Spec
+ and then Units.Table (U2).Utype = Is_Spec
+ and then UNR.Table (Corresponding_Body (U1)).Num_Pred /=
+ UNR.Table (Corresponding_Body (U2)).Num_Pred
+ then
+ if UNR.Table (Corresponding_Body (U1)).Num_Pred <
+ UNR.Table (Corresponding_Body (U2)).Num_Pred
+ then
+ if Debug_Flag_B then
+ Write_Str (" True: same SCC; ");
+ Write_Int (UNR.Table (Corresponding_Body (U1)).Num_Pred);
+ Write_Str (" < ");
+ Write_Int (UNR.Table (Corresponding_Body (U2)).Num_Pred);
+ Write_Eol;
+ end if;
+
+ return True;
+ else
+ if Debug_Flag_B then
+ Write_Str (" False: same SCC; ");
+ Write_Int (UNR.Table (Corresponding_Body (U1)).Num_Pred);
+ Write_Str (" > ");
+ Write_Int (UNR.Table (Corresponding_Body (U2)).Num_Pred);
+ Write_Eol;
+ end if;
+
+ return False;
+ 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.
end if;
return Uname_Less (UT1.Uname, UT2.Uname);
- end Better_Choice;
+ end Better_Choice_Optimistic;
+
+ -------------------------------
+ -- Better_Choice_Pessimistic --
+ -------------------------------
+
+ function Better_Choice_Pessimistic
+ (U1 : Unit_Id;
+ 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_Pessimistic (");
+ 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_Optimistic 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 preelaborated 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, then 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_Older then
+
+ -- The following deal with the case of specs that 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.
+ -- Better_Choice_Pessimistic 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 Better_Choice_Pessimistic 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, Better_Choice_Pessimistic 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
+ -- Better_Choice_Pessimistic 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 Better_Choice_Pessimistic;
----------------
-- Build_Link --
-- 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;
+ 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
+ procedure Choose (Elab_Order : in out Unit_Id_Table; Chosen : Unit_Id) is
+ pragma Assert (Chosen /= No_Unit_Id);
S : Successor_Id;
U : Unit_Id;
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.
+ -- We shouldn't be choosing something with unelaborated predecessors,
+ -- and we shouldn't call this twice on the same unit. But that's not
+ -- true when this is called from Diagnose_Elaboration_Problem.
+
+ if Errors_Detected = 0 then
+ pragma Assert (UNR.Table (Chosen).Num_Pred = 0);
+ pragma Assert (UNR.Table (Chosen).Elab_Position = 0);
+ pragma Assert (not Doing_New or else SCC_Num_Pred (Chosen) = 0);
+ null;
+ 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;
+ Append (Elab_Order, 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.
+ -- 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;
end loop;
end if;
- -- For all successors, decrement the number of predecessors, and
- -- if it becomes zero, then add to no predecessor list.
+ -- 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
No_Pred := U;
end if;
+ if Doing_New and then SCC (U) /= SCC (Chosen) then
+ UNR.Table (SCC (U)).SCC_Num_Pred :=
+ UNR.Table (SCC (U)).SCC_Num_Pred - 1;
+
+ if Debug_Flag_N then
+ Write_Str (" decrementing SCC_Num_Pred for unit ");
+ Write_Unit_Name (Units.Table (U).Uname);
+ Write_Str (" new value = ");
+ Write_Int (SCC_Num_Pred (U));
+ Write_Eol;
+ end if;
+ 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_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.
+ pragma Assert
+ (Errors_Detected > 0 or else Num_Chosen = Natural (Last (Elab_Order)));
+
+ UNR.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.
+ -- 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));
+ Choose (Elab_Order, 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.
+ -- 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
-- 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.
+ -- 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
return U + 1;
end Corresponding_Spec;
+ --------------------
+ -- Debug_Flag_Old --
+ --------------------
+
+ function Debug_Flag_Old return Boolean is
+ begin
+ -- For now, Debug_Flag_P means "use the new algorithm". Once it is
+ -- stable, we intend to remove the "not" below.
+
+ return not Debug_Flag_P;
+ end Debug_Flag_Old;
+
+ ----------------------
+ -- Debug_Flag_Older --
+ ----------------------
+
+ function Debug_Flag_Older return Boolean is
+ begin
+ return Debug_Flag_O;
+ end Debug_Flag_Older;
+
----------------------------------
-- Diagnose_Elaboration_Problem --
----------------------------------
- procedure Diagnose_Elaboration_Problem is
- function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean;
+ procedure Diagnose_Elaboration_Problem
+ (Elab_Order : in out Unit_Id_Table)
+ is
+ function Find_Path
+ (Ufrom : Unit_Id;
+ 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
-- Find_Path --
---------------
- function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is
+ function Find_Path
+ (Ufrom : Unit_Id;
+ 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
S : Successor_Id;
begin
- -- Recursion ends if we are at terminating node and the path
- -- is sufficiently long, generate error message and return True.
+ -- 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);
+ Choose (Elab_Order, U);
return True;
-- All done if already visited
while S /= No_Successor loop
if Find_Link (Succ.Table (S).After, PL + 1) then
Elab_Error_Msg (S);
- Choose (U);
+ Choose (Elab_Order, U);
return True;
end if;
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:
+ -- 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
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.
+ -- 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;
-- Process all units with'ed by Before recursively
- for W in
- Units.Table (Before).First_With .. Units.Table (Before).Last_With
+ 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.
+ -- 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 routine
+ -- 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
if Info = 0 or else Unit_Id (Info) = No_Unit_Id then
declare
- Withed : String :=
- Get_Name_String (Withs.Table (W).Uname);
+ Withed : String :=
+ Get_Name_String (Withs.Table (W).Uname);
Last_Withed : Natural := Withed'Last;
- Withing : String :=
- Get_Name_String (Units.Table (Before).Uname);
+ Withing : String :=
+ Get_Name_String
+ (Units.Table (Before).Uname);
Last_Withing : Natural := Withing'Last;
Spec_Body : String := " (Spec)";
To_Mixed (Withed);
To_Mixed (Withing);
- if Last_Withed > 2 and then
- Withed (Last_Withed - 1) = '%'
+ 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) = '%'
+ 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
+ if Units.Table (Before).Utype = Is_Body
+ or else Units.Table (Before).Utype = Is_Body_Only
then
Spec_Body := " (Body)";
end if;
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);
+ (" $ 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);
+ (" (because $ has a pragma Elaborate_Body)", True);
end if;
if not Zero_Formatting then
-- Find_Elab_Order --
---------------------
- procedure Find_Elab_Order is
- U : Unit_Id;
- Best_So_Far : Unit_Id;
+ procedure Find_Elab_Order
+ (Elab_Order : out Unit_Id_Table;
+ First_Main_Lib_File : File_Name_Type)
+ is
+ function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat;
+ -- Number of cases where the body of a unit immediately follows the
+ -- corresponding spec. Such cases are good, because calls to that unit
+ -- from outside can't get ABE.
+
+ -------------------------
+ -- Num_Spec_Body_Pairs --
+ -------------------------
- begin
- Succ.Init;
- Num_Left := Int (Units.Last - Units.First + 1);
+ function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat is
+ Result : Nat := 0;
- -- Initialize unit table for elaboration control
+ begin
+ for J in Order'First + 1 .. Order'Last loop
+ if Units.Table (Order (J - 1)).Utype = Is_Spec
+ and then Units.Table (Order (J)).Utype = Is_Body
+ and then Corresponding_Spec (Order (J)) = Order (J - 1)
+ then
+ Result := Result + 1;
+ end if;
+ end loop;
- for U in Units.First .. Units.Last loop
- UNR.Append
- ((Successors => No_Successor,
- Num_Pred => 0,
- Nextnp => No_Unit_Id,
- Elab_Order => 0,
- Visited => False,
- Elab_Position => 0));
- end loop;
+ return Result;
+ end Num_Spec_Body_Pairs;
+ -- Local variables
+
+ Old_Elab_Order : Unit_Id_Table;
+
+ -- Start of processing for Find_Elab_Order
+
+ begin
-- Output warning if -p used with no -gnatE units
- if Pessimistic_Elab_Order and not Dynamic_Elaboration_Checks_Specified
+ if Pessimistic_Elab_Order
+ and not Dynamic_Elaboration_Checks_Specified
then
Error_Msg ("?use of -p switch questionable");
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 Do_New then
+ if Debug_Flag_V then
+ Write_Line ("Doing new...");
+ end if;
- if Elab_Dependency_Output or Debug_Flag_E then
- Write_Dependencies;
+ Doing_New := True;
+ Init;
+ Elab_New.Find_Elab_Order (Elab_Order);
end if;
- -- Initialize the no predecessor list
+ -- Elab_New does not support the pessimistic order, so if that was
+ -- requested, use the old results. Use Elab_Old if -dp was selected.
+ -- Elab_New does not yet give proper error messages for illegal
+ -- Elaborate_Alls, so if there is one, run Elab_Old.
- 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;
+ if Do_Old
+ or Pessimistic_Elab_Order
+ or Debug_Flag_Old
+ or Illegal_Elab_All
+ then
+ if Debug_Flag_V then
+ Write_Line ("Doing old...");
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.
+ Doing_New := False;
+ Init;
+ Elab_Old.Find_Elab_Order (Old_Elab_Order);
+ end if;
+
+ declare
+ Old_Order : Unit_Id_Array renames
+ Old_Elab_Order.Table (1 .. Last (Old_Elab_Order));
+ New_Order : Unit_Id_Array renames
+ Elab_Order.Table (1 .. Last (Elab_Order));
+ Old_Pairs : constant Nat := Num_Spec_Body_Pairs (Old_Order);
+ New_Pairs : constant Nat := Num_Spec_Body_Pairs (New_Order);
- Outer : loop
+ begin
+ if Do_Old and Do_New then
+ Write_Line (Get_Name_String (First_Main_Lib_File));
- -- 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
+ pragma Assert (Old_Order'Length = New_Order'Length);
+ pragma Debug (Validate (Old_Order, Doing_New => False));
+ pragma Debug (Validate (New_Order, Doing_New => True));
- Get_No_Pred : while No_Pred = No_Unit_Id loop
- exit Outer when Num_Left < 1;
- Diagnose_Elaboration_Problem;
- end loop Get_No_Pred;
+ -- Misc debug printouts that can be used for experimentation by
+ -- changing the 'if's below.
- U := No_Pred;
- Best_So_Far := No_Unit_Id;
+ if True then
+ if New_Order = Old_Order then
+ Write_Line ("Elab_New: same order.");
+ else
+ Write_Line ("Elab_New: diff order.");
+ end if;
+ end if;
- -- Loop to choose best entry in No_Pred list
+ if New_Order /= Old_Order and then False then
+ Write_Line ("Elaboration orders differ:");
+ Write_Elab_Order
+ (Old_Order, Title => "OLD ELABORATION ORDER");
+ Write_Elab_Order
+ (New_Order, Title => "NEW ELABORATION ORDER");
+ end if;
- No_Pred_Search : loop
- if Debug_Flag_N then
- Write_Str (" considering choice of ");
- Write_Unit_Name (Units.Table (U).Uname);
- Write_Eol;
+ if True then
+ Write_Str ("Pairs: ");
+ Write_Int (Old_Pairs);
- 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);
+ if Old_Pairs = New_Pairs then
+ Write_Str (" = ");
+ elsif Old_Pairs < New_Pairs then
+ Write_Str (" < ");
else
- Write_Str
- (" Elaborate_Body = False");
+ Write_Str (" > ");
end if;
+ Write_Int (New_Pairs);
Write_Eol;
end if;
- -- This is a candididate to be considered for choice
+ if Old_Pairs /= New_Pairs and then False then
+ Write_Str ("Pairs: ");
+ Write_Int (Old_Pairs);
- 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;
+ if Old_Pairs < New_Pairs then
+ Write_Str (" < ");
+ else
+ Write_Str (" > ");
end if;
- Best_So_Far := U;
+ Write_Int (New_Pairs);
+ Write_Eol;
+
+ if Old_Pairs /= New_Pairs and then Debug_Flag_V then
+ Write_Elab_Order
+ (Old_Order, Title => "OLD ELABORATION ORDER");
+ Write_Elab_Order
+ (New_Order, Title => "NEW ELABORATION ORDER");
+ pragma Assert (New_Pairs >= Old_Pairs);
+ end if;
end if;
+ end if;
- U := UNR.Table (U).Nextnp;
- exit No_Pred_Search when U = No_Unit_Id;
- end loop No_Pred_Search;
+ -- The Elab_New algorithm doesn't implement the -p switch, so if that
+ -- was used, use the results from the old algorithm.
- -- 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 Pessimistic_Elab_Order or Debug_Flag_Old then
+ New_Order := Old_Order;
+ end if;
- if Best_So_Far = No_Unit_Id then
- Diagnose_Elaboration_Problem;
+ -- Now set the Elab_Positions in the Units table. It is important to
+ -- do this late, in case we're running both Elab_New and Elab_Old.
- -- Otherwise choose the best candidate found
+ declare
+ Units_Array : Units.Table_Type renames
+ Units.Table (Units.First .. Units.Last);
- else
- Choose (Best_So_Far);
+ begin
+ for J in New_Order'Range loop
+ pragma Assert
+ (UNR.Table (New_Order (J)).Elab_Position = Positive (J));
+ Units_Array (New_Order (J)).Elab_Position := Positive (J);
+ end loop;
+ end;
+
+ if Errors_Detected = 0 then
+
+ -- Display elaboration order if -l was specified
+
+ if Elab_Order_Output then
+ if Zero_Formatting then
+ Write_Elab_Order (New_Order, Title => "");
+ else
+ Write_Elab_Order (New_Order, Title => "ELABORATION ORDER");
+ end if;
+ end if;
+
+ -- Display list of sources in the closure (except predefined
+ -- sources) if -R was used. Include predefined sources if -Ra
+ -- was used.
+
+ if List_Closure then
+ Write_Closure (New_Order);
+ end if;
end if;
- end loop Outer;
+ end;
end Find_Elab_Order;
----------------------
function Get_Line return String;
-- Read the next line from the file content read by Read_File. Strip
- -- leading and trailing blanks. Convert "(spec)" or "(body)" to
+ -- all leading and trailing blanks. Convert "(spec)" or "(body)" to
-- "%s"/"%b". Remove comments (Ada style; "--" to end of line).
function Read_File (Name : String) return String_Ptr;
---------------
function Read_File (Name : String) return String_Ptr is
+
-- All of the following calls should succeed, because we checked the
-- file in Switch.B, but we double check and raise Program_Error on
-- failure, just in case.
while Cur <= S'Last loop
declare
Uname : constant Unit_Name_Type := Name_Find (Get_Line);
+
begin
if Uname = Empty_Name then
null; -- silently skip blank lines
elsif Get_Name_Table_Int (Uname) = 0
or else Unit_Id (Get_Name_Table_Int (Uname)) = No_Unit_Id
then
- Write_Line
- ("""" & Get_Name_String (Uname) &
- """: not present; ignored");
+ if Doing_New then
+ Write_Line
+ ("""" & Get_Name_String (Uname)
+ & """: not present; ignored");
+ end if;
else
declare
Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname);
+
begin
if Is_Internal_File_Name (Units.Table (Cur_Unit).Sfile) then
- Write_Line
- ("""" & Get_Name_String (Uname) &
- """: predefined unit ignored");
+ if Doing_New then
+ Write_Line
+ ("""" & Get_Name_String (Uname) &
+ """: predefined unit ignored");
+ end if;
else
if Prev_Unit /= No_Unit_Id then
- Write_Unit_Name (Units.Table (Prev_Unit).Uname);
- Write_Str (" <-- ");
- Write_Unit_Name (Units.Table (Cur_Unit).Uname);
- Write_Eol;
+ if Doing_New then
+ Write_Unit_Name (Units.Table (Prev_Unit).Uname);
+ Write_Str (" <-- ");
+ Write_Unit_Name (Units.Table (Cur_Unit).Uname);
+ Write_Eol;
+ end if;
Build_Link
(Before => Prev_Unit,
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 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
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 this unit is not an interface to a stand-alone library, process
+ -- WITH references for this unit ignoring 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
+ 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)
-- obsolete unit with's a previous (now disappeared) spec.
if Get_Name_Table_Int (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");
+ if Doing_New 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");
+ end if;
+
goto Next_With;
end if;
-- 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
+ -- Elab_New ignores Elaborate_All and Elab_All_Desirable,
+ -- except for error messages.
+
+ if Withs.Table (W).Elaborate_All and then not Doing_New then
-- Reset flags used to stop multiple visits to a given
-- node.
-- 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
-
+ elsif Withs.Table (W).Elab_All_Desirable
+ and then not Doing_New
+ then
-- Reset flags used to stop multiple visits to a given
-- node.
(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.
+ -- 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 Force_Elab_Order_File /= null then
Force_Elab_Order;
end if;
+
+ -- Output elaboration dependencies if option is set
+
+ if Elab_Dependency_Output or Debug_Flag_E then
+ if Doing_New then
+ Write_Dependencies;
+ end if;
+ end if;
end Gather_Dependencies;
+ ----------
+ -- Init --
+ ----------
+
+ procedure Init is
+ begin
+ Num_Chosen := 0;
+ Num_Left := Int (Units.Last - Units.First + 1);
+ Succ.Init;
+ Elab_All_Entries.Init;
+ UNR.Init;
+
+ -- Initialize unit table for elaboration control
+
+ for U in Units.First .. Units.Last loop
+ UNR.Append
+ ((Successors => No_Successor,
+ Num_Pred => 0,
+ Nextnp => No_Unit_Id,
+ Visited => False,
+ Elab_Position => 0,
+ SCC_Root => No_Unit_Id,
+ Nodes => null,
+ SCC_Num_Pred => 0,
+ Validate_Seen => False));
+ end loop;
+ end Init;
+
------------------
-- 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;
+ return
+ Units.Table (U).Utype = Is_Body
+ or else Units.Table (U).Utype = Is_Body_Only;
end Is_Body_Unit;
-----------------------------
-- If we have a body with separate spec, test flags on the spec
if Units.Table (U).Utype = Is_Body then
- return Units.Table (Corresponding_Spec (U)).Preelab
- or else
- Units.Table (Corresponding_Spec (U)).Pure;
+ return
+ Units.Table (Corresponding_Spec (U)).Preelab
+ or else Units.Table (Corresponding_Spec (U)).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;
+ return Units.Table (U).Preelab or else Units.Table (U).Pure;
end if;
end Is_Pure_Or_Preelab_Unit;
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;
+ return
+ Units.Table (U).Utype = Is_Body
+ and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
end Is_Waiting_Body;
-------------------------
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;
+ Elab_All_Entries.Append ((Needed_By => Unam, Next_Elab => Link));
return Elab_All_Entries.Last;
end Make_Elab_All_Entry;
- -------------------------------
- -- Pessimistic_Better_Choice --
- -------------------------------
+ ----------------
+ -- Unit_Id_Of --
+ ----------------
- 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);
+ function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
+ Info : constant Int := Get_Name_Table_Int (Uname);
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 (")");
+ pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
+ return Unit_Id (Info);
+ end Unit_Id_Of;
+
+ --------------
+ -- Validate --
+ --------------
+
+ procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean) is
+ Cur_SCC : Unit_Id := No_Unit_Id;
+ OK : Boolean := True;
+ Msg : String := "Old: ";
+
+ begin
+ if Doing_New then
+ Msg := "New: ";
end if;
- -- Note: the checks here are applied in sequence, and the ordering is
- -- significant (i.e. the more important criteria are applied first).
+ -- For each unit, assert that its successors are elaborated after it
- -- 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.
+ for J in Order'Range loop
+ declare
+ U : constant Unit_Id := Order (J);
+ S : Successor_Id := UNR.Table (U).Successors;
- -- Prefer a predefined unit to a non-predefined unit
+ begin
+ while S /= No_Successor loop
+ pragma Assert
+ (UNR.Table (Succ.Table (S).After).Elab_Position >
+ UNR.Table (U).Elab_Position,
+ Msg & " elab order failed");
+ S := Succ.Table (S).Next;
+ end loop;
+ end;
+ end loop;
- 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;
+ -- An SCC of size 2 units necessarily consists of a spec and the
+ -- corresponding body. Assert that the body is elaborated immediately
+ -- after the spec, with nothing in between. (We only have SCCs in the
+ -- new algorithm.)
- return True;
+ if Doing_New then
+ for J in Order'Range loop
+ declare
+ U : constant Unit_Id := Order (J);
- 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;
+ begin
+ if Nodes (U)'Length = 2 then
+ if Units.Table (U).Utype = Is_Spec then
+ if Order (J + 1) /= Corresponding_Body (U) then
+ OK := False;
+ Write_Line (Msg & "Bad spec with SCC of size 2:");
+ Write_SCC (SCC (U));
+ end if;
+ end if;
- return False;
+ if Units.Table (U).Utype = Is_Body then
+ if Order (J - 1) /= Corresponding_Spec (U) then
+ OK := False;
+ Write_Line (Msg & "Bad body with SCC of size 2:");
+ Write_SCC (SCC (U));
+ end if;
+ end if;
+ end if;
+ end;
+ end loop;
- -- Prefer an internal unit to a non-internal unit
+ -- Assert that all units of an SCC are elaborated together, with no
+ -- units from other SCCs in between. The above spec/body case is a
+ -- special case of this general rule.
- 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;
+ for J in Order'Range loop
+ declare
+ U : constant Unit_Id := Order (J);
- return True;
+ begin
+ if SCC (U) /= Cur_SCC then
+ Cur_SCC := SCC (U);
+ if UNR.Table (Cur_SCC).Validate_Seen then
+ OK := False;
+ Write_Line (Msg & "SCC not elaborated together:");
+ Write_SCC (Cur_SCC);
+ end if;
- 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;
+ UNR.Table (Cur_SCC).Validate_Seen := True;
+ end if;
+ end;
+ end loop;
+ end if;
- return False;
+ pragma Assert (OK);
+ end Validate;
- -- Prefer a pure or preelaborable unit to one that is not
+ -------------------
+ -- Write_Closure --
+ -------------------
- 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;
+ procedure Write_Closure (Order : Unit_Id_Array) is
+ package Closure_Sources is new Table.Table
+ (Table_Component_Type => File_Name_Type,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Gnatbind.Closure_Sources");
+ -- Table to record the sources in the closure, to avoid duplications
+
+ function Put_In_Sources (S : File_Name_Type) return Boolean;
+ -- Check if S is already in table Sources and put in Sources if it is
+ -- not. Return False if the source is already in Sources, and True if
+ -- it is added.
+
+ --------------------
+ -- Put_In_Sources --
+ --------------------
+
+ function Put_In_Sources (S : File_Name_Type) return Boolean is
+ begin
+ for J in 1 .. Closure_Sources.Last loop
+ if Closure_Sources.Table (J) = S then
+ return False;
+ end if;
+ end loop;
+ Closure_Sources.Append (S);
return True;
+ end Put_In_Sources;
- 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;
+ -- Local variables
- return False;
+ Source : File_Name_Type;
- -- Prefer anything else to a waiting body. We want to make bodies wait
- -- as long as possible, till we are forced to choose them.
+ -- Start of processing for Write_Closure
- 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;
+ begin
+ Closure_Sources.Init;
- return False;
+ if not Zero_Formatting then
+ Write_Eol;
+ Write_Str ("REFERENCED SOURCES");
+ Write_Eol;
+ end if;
- 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;
+ for J in reverse Order'Range loop
+ Source := Units.Table (Order (J)).Sfile;
- return True;
+ -- Do not include same source more than once
- -- Prefer a spec to a body (this is mandatory)
+ if Put_In_Sources (Source)
- 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;
+ -- Do not include run-time units unless -Ra switch set
- return False;
+ and then (List_Closure_All
+ or else not Is_Internal_File_Name (Source))
+ then
+ if not Zero_Formatting then
+ Write_Str (" ");
+ end if;
- 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");
+ Write_Str (Get_Name_String (Source));
+ Write_Eol;
end if;
+ end loop;
- 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?
+ -- Subunits do not appear in the elaboration table because they are
+ -- subsumed by their parent units, but we need to list them for other
+ -- tools. For now they are listed after other files, rather than right
+ -- after their parent, since there is no easy link between the
+ -- elaboration table and the ALIs table ??? As subunits may appear
+ -- repeatedly in the list, if the parent unit appears in the context of
+ -- several units in the closure, duplicates are suppressed.
- -- The normal waiting body preference would have placed the body of
- -- A before the spec of B if it could. Since it could not, then 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)
+ for J in Sdep.First .. Sdep.Last loop
+ Source := Sdep.Table (J).Sfile;
- 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;
+ if Sdep.Table (J).Subunit_Name /= No_Name
+ and then Put_In_Sources (Source)
+ and then not Is_Internal_File_Name (Source)
+ then
+ if not Zero_Formatting then
+ Write_Str (" ");
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 that 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;
+ Write_Str (Get_Name_String (Source));
+ Write_Eol;
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.
+ end loop;
- if Debug_Flag_B then
- Write_Line (" choose on reverse alpha order");
+ if not Zero_Formatting then
+ Write_Eol;
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_Int (Uname);
- begin
- pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
- return Unit_Id (Info);
- end Unit_Id_Of;
+ end Write_Closure;
------------------------
-- Write_Dependencies --
else
Error_Msg_Output
- (" which must be elaborated " &
- "along with its spec:",
+ (" which must be elaborated along with its "
+ & "spec:",
Info => True);
end if;
end if;
end Write_Elab_All_Chain;
+ ----------------------
+ -- Write_Elab_Order --
+ ----------------------
+
+ procedure Write_Elab_Order
+ (Order : Unit_Id_Array; Title : String)
+ is
+ begin
+ if Title /= "" then
+ Write_Eol;
+ Write_Str (Title);
+ Write_Eol;
+ end if;
+
+ for J in Order'Range loop
+ if not Units.Table (Order (J)).SAL_Interface then
+ if not Zero_Formatting then
+ Write_Str (" ");
+ end if;
+
+ Write_Unit_Name (Units.Table (Order (J)).Uname);
+ Write_Eol;
+ end if;
+ end loop;
+
+ if Title /= "" then
+ Write_Eol;
+ end if;
+ end Write_Elab_Order;
+
+ --------------
+ -- Elab_New --
+ --------------
+
+ package body Elab_New is
+
+ generic
+ type Node is (<>);
+ First_Node : Node;
+ Last_Node : Node;
+ type Node_Array is array (Pos range <>) of Node;
+ with function Successors (N : Node) return Node_Array;
+ with procedure Create_SCC (Root : Node; Nodes : Node_Array);
+
+ procedure Compute_Strongly_Connected_Components;
+ -- Compute SCCs for a directed graph. The nodes in the graph are all
+ -- values of type Node in the range First_Node .. Last_Node.
+ -- Successors(N) returns the nodes pointed to by the edges emanating
+ -- from N. Create_SCC is a callback that is called once for each SCC,
+ -- passing in the Root node for that SCC (which is an arbitrary node in
+ -- the SCC used as a representative of that SCC), and the set of Nodes
+ -- in that SCC.
+ --
+ -- This is generic, in case we want to use it elsewhere; then we could
+ -- move this into a separate library unit. Unfortunately, it's not as
+ -- generic as one might like. Ideally, we would have "type Node is
+ -- private;", and pass in iterators to iterate over all nodes, and over
+ -- the successors of a given node. However, that leads to using advanced
+ -- features of Ada that are not allowed in the compiler and binder for
+ -- bootstrapping reason. It also leads to trampolines, which are not
+ -- allowed in the compiler and binder. Restricting Node to be discrete
+ -- allows us to iterate over all nodes with a 'for' loop, and allows us
+ -- to attach temporary information to nodes by having an array indexed
+ -- by Node.
+
+ procedure Compute_Unit_SCCs;
+ -- Use the above generic procedure to compute the SCCs for the graph of
+ -- units. Store in each Unit_Node_Record the SCC_Root and Nodes
+ -- components. Also initialize the SCC_Num_Pred components.
+
+ procedure Find_Elab_All_Errors;
+ -- Generate an error for illegal Elaborate_All pragmas (explicit or
+ -- implicit). A pragma Elaborate_All (Y) on unit X is legal if and only
+ -- if X and Y are in different SCCs.
+
+ -------------------------------------------
+ -- Compute_Strongly_Connected_Components --
+ -------------------------------------------
+
+ procedure Compute_Strongly_Connected_Components is
+
+ -- This uses Tarjan's algorithm for finding SCCs. Comments here are
+ -- intended to tell what it does, but if you want to know how it
+ -- works, you have to look it up. Please do not modify this code
+ -- without reading up on Tarjan's algorithm.
+
+ subtype Node_Index is Nat;
+ No_Index : constant Node_Index := 0;
+
+ Num_Nodes : constant Nat :=
+ Node'Pos (Last_Node) - Node'Pos (First_Node) + 1;
+ Stack : Node_Array (1 .. Num_Nodes);
+ Top : Node_Index := 0;
+ -- Stack of nodes, pushed when first visited. All nodes of an SCC are
+ -- popped at once when the SCC is found.
+
+ subtype Valid_Node is Node range First_Node .. Last_Node;
+ Node_Indices : array (Valid_Node) of Node_Index :=
+ (others => No_Index);
+ -- Each node has an "index", which is the sequential number in the
+ -- order in which they are visited in the recursive walk. No_Index
+ -- means "not yet visited"; we want to avoid walking any node more
+ -- than once.
+
+ Index : Node_Index := 1;
+ -- Next value to be assigned to a node index
+
+ Low_Links : array (Valid_Node) of Node_Index;
+ -- Low_Links (N) is the smallest index of nodes reachable from N
+
+ On_Stack : array (Valid_Node) of Boolean := (others => False);
+ -- True if the node is currently on the stack
+
+ procedure Walk (N : Valid_Node);
+ -- Recursive depth-first graph walk, with the node index used to
+ -- avoid visiting a node more than once.
+
+ ----------
+ -- Walk --
+ ----------
+
+ procedure Walk (N : Valid_Node) is
+ Stack_Position_Of_N : constant Pos := Top + 1;
+ S : constant Node_Array := Successors (N);
+
+ begin
+ -- Assign the index and low link, increment Index for next call to
+ -- Walk.
+
+ Node_Indices (N) := Index;
+ Low_Links (N) := Index;
+ Index := Index + 1;
+
+ -- Push it one the stack:
+
+ Top := Stack_Position_Of_N;
+ Stack (Top) := N;
+ On_Stack (N) := True;
+
+ -- Walk not-yet-visited subnodes, and update low link for visited
+ -- ones as appropriate.
+
+ for J in S'Range loop
+ if Node_Indices (S (J)) = No_Index then
+ Walk (S (J));
+ Low_Links (N) :=
+ Node_Index'Min (Low_Links (N), Low_Links (S (J)));
+ elsif On_Stack (S (J)) then
+ Low_Links (N) :=
+ Node_Index'Min (Low_Links (N), Node_Indices (S (J)));
+ end if;
+ end loop;
+
+ -- If the index is (still) equal to the low link, we've found an
+ -- SCC. Pop the whole SCC off the stack, and call Create_SCC.
+
+ if Low_Links (N) = Node_Indices (N) then
+ declare
+ SCC : Node_Array renames
+ Stack (Stack_Position_Of_N .. Top);
+ pragma Assert (SCC'Length >= 1);
+ pragma Assert (SCC (SCC'First) = N);
+
+ begin
+ for J in SCC'Range loop
+ On_Stack (SCC (J)) := False;
+ end loop;
+
+ Create_SCC (Root => N, Nodes => SCC);
+ pragma Assert (Top - SCC'Length = Stack_Position_Of_N - 1);
+ Top := Stack_Position_Of_N - 1; -- pop all
+ end;
+ end if;
+ end Walk;
+
+ -- Start of processing for Compute_Strongly_Connected_Components
+
+ begin
+ -- Walk all the nodes that have not yet been walked
+
+ for N in Valid_Node loop
+ if Node_Indices (N) = No_Index then
+ Walk (N);
+ end if;
+ end loop;
+ end Compute_Strongly_Connected_Components;
+
+ -----------------------
+ -- Compute_Unit_SCCs --
+ -----------------------
+
+ procedure Compute_Unit_SCCs is
+ function Successors (U : Unit_Id) return Unit_Id_Array;
+ -- Return all the units that must be elaborated after U. In addition,
+ -- if U is a body, include the corresponding spec; this ensures that
+ -- a spec/body pair are always in the same SCC.
+
+ procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array);
+ -- Set Nodes of the Root, and set SCC_Root of all the Nodes
+
+ procedure Init_SCC_Num_Pred (U : Unit_Id);
+ -- Initialize the SCC_Num_Pred fields, so that the root of each SCC
+ -- has a count of the number of successors of all the units in the
+ -- SCC, but only for successors outside the SCC.
+
+ procedure Compute_SCCs is new Compute_Strongly_Connected_Components
+ (Node => Unit_Id,
+ First_Node => Units.First,
+ Last_Node => Units.Last,
+ Node_Array => Unit_Id_Array,
+ Successors => Successors,
+ Create_SCC => Create_SCC);
+
+ ----------------
+ -- Create_SCC --
+ ----------------
+
+ procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array) is
+ begin
+ if Debug_Flag_V then
+ Write_Str ("Root = ");
+ Write_Int (Int (Root));
+ Write_Str (" ");
+ Write_Unit_Name (Units.Table (Root).Uname);
+ Write_Str (" -- ");
+ Write_Int (Nodes'Length);
+ Write_Str (" units:");
+ Write_Eol;
+
+ for J in Nodes'Range loop
+ Write_Str (" ");
+ Write_Int (Int (Nodes (J)));
+ Write_Str (" ");
+ Write_Unit_Name (Units.Table (Nodes (J)).Uname);
+ Write_Eol;
+ end loop;
+ end if;
+
+ pragma Assert (Nodes (Nodes'First) = Root);
+ pragma Assert (UNR.Table (Root).Nodes = null);
+ UNR.Table (Root).Nodes := new Unit_Id_Array'(Nodes);
+
+ for J in Nodes'Range loop
+ pragma Assert (SCC (Nodes (J)) = No_Unit_Id);
+ UNR.Table (Nodes (J)).SCC_Root := Root;
+ end loop;
+ end Create_SCC;
+
+ ----------------
+ -- Successors --
+ ----------------
+
+ function Successors (U : Unit_Id) return Unit_Id_Array is
+ S : Successor_Id := UNR.Table (U).Successors;
+ Tab : Unit_Id_Table;
+
+ begin
+ -- Pretend that a spec is a successor of its body (even though it
+ -- isn't), just so both get included.
+
+ if Units.Table (U).Utype = Is_Body then
+ Append (Tab, Corresponding_Spec (U));
+ end if;
+
+ -- Now include the real successors
+
+ while S /= No_Successor loop
+ pragma Assert (Succ.Table (S).Before = U);
+ Append (Tab, Succ.Table (S).After);
+ S := Succ.Table (S).Next;
+ end loop;
+
+ declare
+ Result : constant Unit_Id_Array := Tab.Table (1 .. Last (Tab));
+
+ begin
+ Free (Tab);
+ return Result;
+ end;
+ end Successors;
+
+ -----------------------
+ -- Init_SCC_Num_Pred --
+ -----------------------
+
+ procedure Init_SCC_Num_Pred (U : Unit_Id) is
+ begin
+ if UNR.Table (U).Visited then
+ return;
+ end if;
+
+ UNR.Table (U).Visited := True;
+
+ declare
+ S : Successor_Id := UNR.Table (U).Successors;
+
+ begin
+ while S /= No_Successor loop
+ pragma Assert (Succ.Table (S).Before = U);
+ Init_SCC_Num_Pred (Succ.Table (S).After);
+
+ if SCC (U) /= SCC (Succ.Table (S).After) then
+ UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred :=
+ UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred + 1;
+ end if;
+
+ S := Succ.Table (S).Next;
+ end loop;
+ end;
+ end Init_SCC_Num_Pred;
+
+ -- Start of processing for Compute_Unit_SCCs
+
+ begin
+ Compute_SCCs;
+
+ for Uref in UNR.First .. UNR.Last loop
+ pragma Assert (not UNR.Table (Uref).Visited);
+ null;
+ end loop;
+
+ for Uref in UNR.First .. UNR.Last loop
+ Init_SCC_Num_Pred (Uref);
+ end loop;
+
+ -- Assert that SCC_Root of all units has been set to a valid unit,
+ -- and that SCC_Num_Pred has not been modified in non-root units.
+
+ for Uref in UNR.First .. UNR.Last loop
+ pragma Assert (UNR.Table (Uref).SCC_Root /= No_Unit_Id);
+ pragma Assert (UNR.Table (Uref).SCC_Root in UNR.First .. UNR.Last);
+
+ if SCC (Uref) /= Uref then
+ pragma Assert (UNR.Table (Uref).SCC_Num_Pred = 0);
+ null;
+ end if;
+ end loop;
+ end Compute_Unit_SCCs;
+
+ --------------------------
+ -- Find_Elab_All_Errors --
+ --------------------------
+
+ procedure Find_Elab_All_Errors is
+ Withed_Unit : Unit_Id;
+
+ begin
+ for U in Units.First .. Units.Last loop
+
+ -- If this unit is not an interface to a stand-alone library,
+ -- process WITH references for this unit ignoring 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 Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then
+ goto Next_With;
+ end if;
+
+ Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname);
+
+ -- If it's Elaborate_All or Elab_All_Desirable, check
+ -- that the withER and withEE are not in the same SCC.
+
+ if Withs.Table (W).Elaborate_All
+ or else Withs.Table (W).Elab_All_Desirable
+ then
+ if SCC (U) = SCC (Withed_Unit) then
+ Illegal_Elab_All := True; -- ????
+
+ -- We could probably give better error messages
+ -- than Elab_Old here, but for now, to avoid
+ -- disruption, we don't give any error here.
+ -- Instead, we set the Illegal_Elab_All flag above,
+ -- and then run the Elab_Old algorithm to issue the
+ -- error message. Ideally, we would like to print
+ -- multiple errors rather than stopping after the
+ -- first cycle.
+
+ if False then
+ Error_Msg_Output
+ ("illegal pragma Elaborate_All",
+ Info => False);
+ end if;
+ end if;
+ end if;
+ end if;
+
+ <<Next_With>>
+ null;
+ end loop;
+ end if;
+ end loop;
+ end Find_Elab_All_Errors;
+
+ ---------------------
+ -- Find_Elab_Order --
+ ---------------------
+
+ procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
+ Best_So_Far : Unit_Id;
+ U : Unit_Id;
+
+ begin
+ -- Gather dependencies and output them if option set
+
+ Gather_Dependencies;
+
+ Compute_Unit_SCCs;
+
+ -- 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.
+ -- ????But Diagnose_Elaboration_Problem always raises an
+ -- exception.
+
+ Get_No_Pred : while No_Pred = No_Unit_Id loop
+ exit Outer when Num_Left < 1;
+ Diagnose_Elaboration_Problem (Elab_Order);
+ 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;
+
+ -- Don't even consider units whose SCC is not ready. This
+ -- ensures that all units of an SCC will be elaborated
+ -- together, with no other units in between.
+
+ if SCC_Num_Pred (U) = 0
+ and then 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;
+
+ -- Choose the best candidate found
+
+ Choose (Elab_Order, Best_So_Far);
+
+ -- If it's a spec with a body, and the body is not yet chosen,
+ -- choose the body if possible. The case where the body is
+ -- already chosen is Elaborate_Body; the above call to Choose
+ -- the spec will also Choose the body.
+
+ if Units.Table (Best_So_Far).Utype = Is_Spec
+ and then UNR.Table
+ (Corresponding_Body (Best_So_Far)).Elab_Position = 0
+ then
+ declare
+ Choose_The_Body : constant Boolean :=
+ UNR.Table (Corresponding_Body
+ (Best_So_Far)).Num_Pred = 0;
+
+ begin
+ if Debug_Flag_B then
+ Write_Str ("Can we choose the body?... ");
+
+ if Choose_The_Body then
+ Write_Line ("Yes!");
+ else
+ Write_Line ("No.");
+ end if;
+ end if;
+
+ if Choose_The_Body then
+ Choose (Elab_Order, Corresponding_Body (Best_So_Far));
+ end if;
+ end;
+ end if;
+
+ -- Finally, choose all the rest of the units in the same SCC as
+ -- Best_So_Far. If it hasn't been chosen (Elab_Position = 0), and
+ -- it's ready to be chosen (Num_Pred = 0), then we can choose it.
+
+ loop
+ declare
+ Chose_One_Or_More : Boolean := False;
+ SCC : Unit_Id_Array renames Nodes (Best_So_Far).all;
+
+ begin
+ for J in SCC'Range loop
+ if UNR.Table (SCC (J)).Elab_Position = 0
+ and then UNR.Table (SCC (J)).Num_Pred = 0
+ then
+ Chose_One_Or_More := True;
+ Choose (Elab_Order, SCC (J));
+ end if;
+ end loop;
+
+ exit when not Chose_One_Or_More;
+ end;
+ end loop;
+ end loop Outer;
+
+ Find_Elab_All_Errors;
+ end Find_Elab_Order;
+
+ -----------
+ -- Nodes --
+ -----------
+
+ function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr is
+ begin
+ return UNR.Table (SCC (U)).Nodes;
+ end Nodes;
+
+ ---------
+ -- SCC --
+ ---------
+
+ function SCC (U : Unit_Id) return Unit_Id is
+ begin
+ return UNR.Table (U).SCC_Root;
+ end SCC;
+
+ ------------------
+ -- SCC_Num_Pred --
+ ------------------
+
+ function SCC_Num_Pred (U : Unit_Id) return Int is
+ begin
+ return UNR.Table (SCC (U)).SCC_Num_Pred;
+ end SCC_Num_Pred;
+
+ ---------------
+ -- Write_SCC --
+ ---------------
+
+ procedure Write_SCC (U : Unit_Id) is
+ pragma Assert (SCC (U) = U);
+ begin
+ for J in Nodes (U)'Range loop
+ Write_Int (Int (UNR.Table (Nodes (U) (J)).Elab_Position));
+ Write_Str (". ");
+ Write_Unit_Name (Units.Table (Nodes (U) (J)).Uname);
+ Write_Eol;
+ end loop;
+
+ Write_Eol;
+ end Write_SCC;
+
+ end Elab_New;
+
+ --------------
+ -- Elab_Old --
+ --------------
+
+ package body Elab_Old is
+
+ ---------------------
+ -- Find_Elab_Order --
+ ---------------------
+
+ procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
+ Best_So_Far : Unit_Id;
+ U : Unit_Id;
+
+ begin
+ -- Gather dependencies and output them if option set
+
+ Gather_Dependencies;
+
+ -- 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.
+ -- ????But Diagnose_Elaboration_Problem always raises an
+ -- exception.
+
+ Get_No_Pred : while No_Pred = No_Unit_Id loop
+ exit Outer when Num_Left < 1;
+ Diagnose_Elaboration_Problem (Elab_Order);
+ 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 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;
+
+ -- Choose the best candidate found
+
+ Choose (Elab_Order, Best_So_Far);
+ end loop Outer;
+ end Find_Elab_Order;
+
+ end Elab_Old;
+
end Binde;
------------------------------------------------------------------------------
with ALI; use ALI;
-with Binde; use Binde;
with Casing; use Casing;
with Fname; use Fname;
with Gnatvsn; use Gnatvsn;
with GNAT.HTable;
package body Bindgen is
+ use Binde.Unit_Id_Tables;
Statement_Buffer : String (1 .. 1000);
-- Buffer used for constructing output statements
- Last : Natural := 0;
- -- Last location in Statement_Buffer currently set
+ Stm_Last : Natural := 0;
+ -- Stm_Last location in Statement_Buffer currently set
With_GNARL : Boolean := False;
-- Flag which indicates whether the program uses the GNARL library
-- that the information is consistent across units. The entries
-- in this table are n/u/r/s for not set/user/runtime/system.
- package IS_Pragma_Settings is new Table.Table (
- Table_Component_Type => Character,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => 100,
- Table_Increment => 200,
- Table_Name => "IS_Pragma_Settings");
+ package IS_Pragma_Settings is new Table.Table
+ (Table_Component_Type => Character,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 100,
+ Table_Increment => 200,
+ Table_Name => "IS_Pragma_Settings");
-- This table assembles the Priority_Specific_Dispatching pragma
-- information from all the units in the partition. Note that Bcheck has
-- The entries in this table are the upper case first character of the
-- policy name, e.g. 'F' for FIFO_Within_Priorities.
- package PSD_Pragma_Settings is new Table.Table (
- Table_Component_Type => Character,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => 100,
- Table_Increment => 200,
- Table_Name => "PSD_Pragma_Settings");
+ package PSD_Pragma_Settings is new Table.Table
+ (Table_Component_Type => Character,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 100,
+ Table_Increment => 200,
+ Table_Name => "PSD_Pragma_Settings");
----------------------------
-- Bind_Environment Table --
-- Local Subprograms --
-----------------------
- procedure Gen_Adainit;
+ procedure Gen_Adainit (Elab_Order : Unit_Id_Array);
-- Generates the Adainit procedure
procedure Gen_Adafinal;
procedure Gen_CodePeer_Wrapper;
-- For CodePeer, generate wrapper which calls user-defined main subprogram
- procedure Gen_Elab_Calls;
+ procedure Gen_Elab_Calls (Elab_Order : Unit_Id_Array);
-- Generate sequence of elaboration calls
- procedure Gen_Elab_Externals;
+ procedure Gen_Elab_Externals (Elab_Order : Unit_Id_Array);
-- Generate sequence of external declarations for elaboration
- procedure Gen_Elab_Order;
+ procedure Gen_Elab_Order (Elab_Order : Unit_Id_Array);
-- Generate comments showing elaboration order chosen
- procedure Gen_Finalize_Library;
+ procedure Gen_Finalize_Library (Elab_Order : Unit_Id_Array);
-- Generate a sequence of finalization calls to elaborated packages
procedure Gen_Main;
-- Generate procedure main
- procedure Gen_Object_Files_Options;
+ procedure Gen_Object_Files_Options (Elab_Order : Unit_Id_Array);
-- Output comments containing a list of the full names of the object
-- files to be linked and the list of linker options supplied by
-- Linker_Options pragmas in the source.
- procedure Gen_Output_File_Ada (Filename : String);
+ procedure Gen_Output_File_Ada
+ (Filename : String;
+ Elab_Order : Unit_Id_Array);
-- Generate Ada output file
procedure Gen_Restrictions;
-- the encoding method used for the main program source. If there is no
-- main program source (-z switch used), returns brackets ('b').
- function Has_Finalizer return Boolean;
+ function Has_Finalizer (Elab_Order : Unit_Id_Array) return Boolean;
-- Determine whether the current unit has at least one library-level
-- finalizer.
- function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;
+ function Lt_Linker_Option (Op1 : Natural; Op2 : Natural) return Boolean;
-- Compare linker options, when sorting, first according to
-- Is_Internal_File (internal files come later) and then by
-- elaboration order position (latest to earliest).
procedure Move_Linker_Option (From : Natural; To : Natural);
-- Move routine for sorting linker options
- procedure Resolve_Binder_Options;
+ procedure Resolve_Binder_Options (Elab_Order : Unit_Id_Array);
-- Set the value of With_GNARL
procedure Set_Char (C : Character);
- -- Set given character in Statement_Buffer at the Last + 1 position
- -- and increment Last by one to reflect the stored character.
+ -- Set given character in Statement_Buffer at the Stm_Last + 1 position
+ -- and increment Stm_Last by one to reflect the stored character.
procedure Set_Int (N : Int);
-- Set given value in decimal in Statement_Buffer with no spaces starting
- -- at the Last + 1 position, and updating Last past the value. A minus sign
- -- is output for a negative value.
+ -- at the Stm_Last + 1 position, and updating Stm_Last past the value. A
+ -- minus sign is output for a negative value.
procedure Set_Boolean (B : Boolean);
- -- Set given boolean value in Statement_Buffer at the Last + 1 position
- -- and update Last past the value.
+ -- Set given boolean value in Statement_Buffer at the Stm_Last + 1 position
+ -- and update Stm_Last past the value.
procedure Set_IS_Pragma_Table;
-- Initializes contents of IS_Pragma_Settings table from ALI table
procedure Set_Main_Program_Name;
-- Given the main program name in Name_Buffer (length in Name_Len) generate
-- the name of the routine to be used in the call. The name is generated
- -- starting at Last + 1, and Last is updated past it.
+ -- starting at Stm_Last + 1, and Stm_Last is updated past it.
procedure Set_Name_Buffer;
-- Set the value stored in positions 1 .. Name_Len of the Name_Buffer
procedure Set_String (S : String);
-- Sets characters of given string in Statement_Buffer, starting at the
- -- Last + 1 position, and updating last past the string value.
+ -- Stm_Last + 1 position, and updating last past the string value.
procedure Set_String_Replace (S : String);
-- Replaces the last S'Length characters in the Statement_Buffer with the
procedure Set_Unit_Name;
-- Given a unit name in the Name_Buffer, copy it into Statement_Buffer,
- -- starting at the Last + 1 position and update Last past the value.
- -- Each dot (.) will be qualified into double underscores (__).
+ -- starting at the Stm_Last + 1 position and update Stm_Last past the
+ -- value. Each dot (.) will be qualified into double underscores (__).
procedure Set_Unit_Number (U : Unit_Id);
-- Sets unit number (first unit is 1, leading zeroes output to line up all
-- number of units.
procedure Write_Statement_Buffer;
- -- Write out contents of statement buffer up to Last, and reset Last to 0
+ -- Write out contents of statement buffer up to Stm_Last, and reset
+ -- Stm_Last to 0.
procedure Write_Statement_Buffer (S : String);
-- First writes its argument (using Set_String (S)), then writes out the
- -- contents of statement buffer up to Last, and reset Last to 0
+ -- contents of statement buffer up to Stm_Last, and reset Stm_Last to 0
procedure Write_Bind_Line (S : String);
-- Write S (an LF-terminated string) to the binder file (for use with
-- Gen_Adainit --
-----------------
- procedure Gen_Adainit is
+ procedure Gen_Adainit (Elab_Order : Unit_Id_Array) is
Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU;
Write_Statement_Buffer;
end if;
- -- Initialize stack limit variable of the environment task if the
- -- stack check method is stack limit and stack check is enabled.
+ -- Initialize stack limit variable of the environment task if the stack
+ -- check method is stack limit and stack check is enabled.
if Stack_Check_Limits_On_Target
and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
WBI ("");
end if;
- Gen_Elab_Calls;
+ Gen_Elab_Calls (Elab_Order);
if not CodePeer_Mode then
-------------------------
procedure Gen_Bind_Env_String is
- KN, VN : Name_Id := No_Name;
- Amp : Character;
-
procedure Write_Name_With_Len (Nam : Name_Id);
-- Write Nam as a string literal, prefixed with one
-- character encoding Nam's length.
Write_String_Table_Entry (End_String);
end Write_Name_With_Len;
+ -- Local variables
+
+ Amp : Character;
+ KN : Name_Id := No_Name;
+ VN : Name_Id := No_Name;
+
-- Start of processing for Gen_Bind_Env_String
begin
Bind_Environment.Get_First (KN, VN);
+
if VN = No_Name then
return;
end if;
-- Gen_Elab_Calls --
--------------------
- procedure Gen_Elab_Calls is
+ procedure Gen_Elab_Calls (Elab_Order : Unit_Id_Array) is
Check_Elab_Flag : Boolean;
begin
-- Loop through elaboration order entries
- for E in Elab_Order.First .. Elab_Order.Last loop
+ for E in Elab_Order'Range loop
declare
- Unum : constant Unit_Id := Elab_Order.Table (E);
+ Unum : constant Unit_Id := Elab_Order (E);
U : Unit_Record renames Units.Table (Unum);
Unum_Spec : Unit_Id;
-- Gen_Elab_Externals --
------------------------
- procedure Gen_Elab_Externals is
+ procedure Gen_Elab_Externals (Elab_Order : Unit_Id_Array) is
begin
if CodePeer_Mode then
return;
end if;
- for E in Elab_Order.First .. Elab_Order.Last loop
+ for E in Elab_Order'Range loop
declare
- Unum : constant Unit_Id := Elab_Order.Table (E);
+ Unum : constant Unit_Id := Elab_Order (E);
U : Unit_Record renames Units.Table (Unum);
begin
-- Gen_Elab_Order --
--------------------
- procedure Gen_Elab_Order is
+ procedure Gen_Elab_Order (Elab_Order : Unit_Id_Array) is
begin
WBI (" -- BEGIN ELABORATION ORDER");
- for J in Elab_Order.First .. Elab_Order.Last loop
+ for J in Elab_Order'Range loop
Set_String (" -- ");
- Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
+ Get_Name_String (Units.Table (Elab_Order (J)).Uname);
Set_Name_Buffer;
Write_Statement_Buffer;
end loop;
-- Gen_Finalize_Library --
--------------------------
- procedure Gen_Finalize_Library is
- Count : Int := 1;
- U : Unit_Record;
- Uspec : Unit_Record;
- Unum : Unit_Id;
-
+ procedure Gen_Finalize_Library (Elab_Order : Unit_Id_Array) is
procedure Gen_Header;
-- Generate the header of the finalization routine
WBI (" begin");
end Gen_Header;
+ -- Local variables
+
+ Count : Int := 1;
+ U : Unit_Record;
+ Uspec : Unit_Record;
+ Unum : Unit_Id;
+
-- Start of processing for Gen_Finalize_Library
begin
return;
end if;
- for E in reverse Elab_Order.First .. Elab_Order.Last loop
- Unum := Elab_Order.Table (E);
+ for E in reverse Elab_Order'Range loop
+ Unum := Elab_Order (E);
U := Units.Table (Unum);
-- Dealing with package bodies is a little complicated. In such
end if;
end if;
- -- Generate a reference to Ada_Main_Program_Name. This symbol is
- -- not referenced elsewhere in the generated program, but is needed
- -- by the debugger (that's why it is generated in the first place).
- -- The reference stops Ada_Main_Program_Name from being optimized
- -- away by smart linkers, such as the AiX linker.
+ -- Generate a reference to Ada_Main_Program_Name. This symbol is not
+ -- referenced elsewhere in the generated program, but is needed by
+ -- the debugger (that's why it is generated in the first place). The
+ -- reference stops Ada_Main_Program_Name from being optimized away by
+ -- smart linkers, such as the AiX linker.
-- Because this variable is unused, we make this variable "aliased"
-- with a pragma Volatile in order to tell the compiler to preserve
WBI (" gnat_envp := envp;");
WBI ("");
- -- If configurable run time and no command line args, then nothing
- -- needs to be done since the gnat_argc/argv/envp variables are
- -- suppressed in this case.
+ -- If configurable run time and no command line args, then nothing needs
+ -- to be done since the gnat_argc/argv/envp variables are suppressed in
+ -- this case.
elsif Configurable_Run_Time_On_Target then
null;
-- Gen_Object_Files_Options --
------------------------------
- procedure Gen_Object_Files_Options is
+ procedure Gen_Object_Files_Options (Elab_Order : Unit_Id_Array) is
Lgnat : Natural;
- -- This keeps track of the position in the sorted set of entries
- -- in the Linker_Options table of where the first entry from an
- -- internal file appears.
+ -- This keeps track of the position in the sorted set of entries in the
+ -- Linker_Options table of where the first entry from an internal file
+ -- appears.
Linker_Option_List_Started : Boolean := False;
-- Set to True when "LINKER OPTION LIST" is displayed
Set_List_File (Object_List_Filename.all);
end if;
- for E in Elab_Order.First .. Elab_Order.Last loop
+ for E in Elab_Order'Range loop
-- If not spec that has an associated body, then generate a comment
-- giving the name of the corresponding object file.
- if not Units.Table (Elab_Order.Table (E)).SAL_Interface
- and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec
+ if not Units.Table (Elab_Order (E)).SAL_Interface
+ and then Units.Table (Elab_Order (E)).Utype /= Is_Spec
then
Get_Name_String
(ALIs.Table
- (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name);
+ (Units.Table (Elab_Order (E)).My_ALI).Ofile_Full_Name);
-- If the presence of an object file is necessary or if it exists,
-- then use it.
for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
declare
Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J);
+
begin
Name_Len := 0;
Add_Str_To_Name_Buffer ("-L");
-- Gen_Output_File --
---------------------
- procedure Gen_Output_File (Filename : String) is
+ procedure Gen_Output_File
+ (Filename : String;
+ Elab_Order : Unit_Id_Array)
+ is
begin
-- Acquire settings for Interrupt_State pragmas
-- Count number of elaboration calls
- for E in Elab_Order.First .. Elab_Order.Last loop
- if Units.Table (Elab_Order.Table (E)).No_Elab then
+ for E in Elab_Order'Range loop
+ if Units.Table (Elab_Order (E)).No_Elab then
null;
else
Num_Elab_Calls := Num_Elab_Calls + 1;
-- Generate output file in appropriate language
- Gen_Output_File_Ada (Filename);
+ Gen_Output_File_Ada (Filename, Elab_Order);
end Gen_Output_File;
-------------------------
-- Gen_Output_File_Ada --
-------------------------
- procedure Gen_Output_File_Ada (Filename : String) is
-
+ procedure Gen_Output_File_Ada
+ (Filename : String; Elab_Order : Unit_Id_Array)
+ is
Ada_Main : constant String := Get_Ada_Main_Name;
-- Name to be used for generated Ada main program. See the body of
-- function Get_Ada_Main_Name for details on the form of the name.
Needs_Library_Finalization : constant Boolean :=
- not Configurable_Run_Time_On_Target and then Has_Finalizer;
+ not Configurable_Run_Time_On_Target
+ and then Has_Finalizer (Elab_Order);
-- For restricted run-time libraries (ZFP and Ravenscar) tasks are
-- non-terminating, so we do not want finalization.
WBI ("with System.Secondary_Stack;");
end if;
- Resolve_Binder_Options;
+ Resolve_Binder_Options (Elab_Order);
-- Generate standard with's
end if;
Gen_Versions;
- Gen_Elab_Order;
+ Gen_Elab_Order (Elab_Order);
-- Spec is complete
-- Generate externals for elaboration entities
- Gen_Elab_Externals;
+ Gen_Elab_Externals (Elab_Order);
if not CodePeer_Mode then
if not Suppress_Standard_Library_On_Target then
if not Cumulative_Restrictions.Set (No_Finalization) then
if Needs_Library_Finalization then
- Gen_Finalize_Library;
+ Gen_Finalize_Library (Elab_Order);
end if;
Gen_Adafinal;
end if;
- Gen_Adainit;
+ Gen_Adainit (Elab_Order);
if Bind_Main_Program then
Gen_Main;
-- Output object file list and the Ada body is complete
- Gen_Object_Files_Options;
+ Gen_Object_Files_Options (Elab_Order);
WBI ("");
WBI ("end " & Ada_Main & ";");
WBI (" type Version_32 is mod 2 ** 32;");
for U in Units.First .. Units.Last loop
if not Units.Table (U).SAL_Interface
- and then
- (not Bind_For_Library or else Units.Table (U).Directly_Scanned)
+ and then (not Bind_For_Library
+ or else Units.Table (U).Directly_Scanned)
then
Increment_Ubuf;
WBI (" " & Ubuf & " : constant Version_32 := 16#" &
function Get_Ada_Main_Name return String is
Suffix : constant String := "_00";
Name : String (1 .. Opt.Ada_Main_Name.all'Length + Suffix'Length) :=
- Opt.Ada_Main_Name.all & Suffix;
+ Opt.Ada_Main_Name.all & Suffix;
Nlen : Natural;
begin
- -- For CodePeer, we want reproducible names (independent of other
- -- mains that may or may not be present) that don't collide
- -- when analyzing multiple mains and which are easily recognizable
- -- as "ada_main" names.
+ -- For CodePeer, we want reproducible names (independent of other mains
+ -- that may or may not be present) that don't collide when analyzing
+ -- multiple mains and which are easily recognizable as "ada_main" names.
if CodePeer_Mode then
Get_Name_String (Units.Table (First_Unit_Entry).Uname);
- return "ada_main_for_" &
- Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2));
+
+ return
+ "ada_main_for_" &
+ Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2));
end if;
-- This loop tries the following possibilities in order
-- Has_Finalizer --
-------------------
- function Has_Finalizer return Boolean is
+ function Has_Finalizer (Elab_Order : Unit_Id_Array) return Boolean is
U : Unit_Record;
Unum : Unit_Id;
begin
- for E in reverse Elab_Order.First .. Elab_Order.Last loop
- Unum := Elab_Order.Table (E);
+ for E in reverse Elab_Order'Range loop
+ Unum := Elab_Order (E);
U := Units.Table (Unum);
-- We are only interested in non-generic packages
-- Lt_Linker_Option --
----------------------
- function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is
+ function Lt_Linker_Option (Op1 : Natural; Op2 : Natural) return Boolean is
begin
-- Sort internal files last
return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
>
Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position;
-
end if;
end Lt_Linker_Option;
-- Resolve_Binder_Options --
----------------------------
- procedure Resolve_Binder_Options is
-
+ procedure Resolve_Binder_Options (Elab_Order : Unit_Id_Array) is
procedure Check_Package (Var : in out Boolean; Name : String);
-- Set Var to true iff the current identifier in Namet is Name. Do
-- nothing if it doesn't match. This procedure is just a helper to
-- Start of processing for Resolve_Binder_Options
begin
- for E in Elab_Order.First .. Elab_Order.Last loop
- Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
+ for E in Elab_Order'Range loop
+ Get_Name_String (Units.Table (Elab_Order (E)).Uname);
-- This is not a perfect approach, but is the current protocol
-- between the run-time and the binder to indicate that tasking is
-----------------
procedure Set_Boolean (B : Boolean) is
- True_Str : constant String := "True";
False_Str : constant String := "False";
+ True_Str : constant String := "True";
+
begin
if B then
- Statement_Buffer (Last + 1 .. Last + True_Str'Length) := True_Str;
- Last := Last + True_Str'Length;
+ Statement_Buffer (Stm_Last + 1 .. Stm_Last + True_Str'Length) :=
+ True_Str;
+ Stm_Last := Stm_Last + True_Str'Length;
else
- Statement_Buffer (Last + 1 .. Last + False_Str'Length) := False_Str;
- Last := Last + False_Str'Length;
+ Statement_Buffer (Stm_Last + 1 .. Stm_Last + False_Str'Length) :=
+ False_Str;
+ Stm_Last := Stm_Last + False_Str'Length;
end if;
end Set_Boolean;
procedure Set_Char (C : Character) is
begin
- Last := Last + 1;
- Statement_Buffer (Last) := C;
+ Stm_Last := Stm_Last + 1;
+ Statement_Buffer (Stm_Last) := C;
end Set_Char;
-------------
Set_Int (N / 10);
end if;
- Last := Last + 1;
- Statement_Buffer (Last) :=
+ Stm_Last := Stm_Last + 1;
+ Statement_Buffer (Stm_Last) :=
Character'Val (N mod 10 + Character'Pos ('0'));
end if;
end Set_Int;
loop
declare
Inum : constant Int :=
- Interrupt_States.Table (K).Interrupt_Id;
+ Interrupt_States.Table (K).Interrupt_Id;
Stat : constant Character :=
- Interrupt_States.Table (K).Interrupt_State;
+ Interrupt_States.Table (K).Interrupt_State;
begin
while IS_Pragma_Settings.Last < Inum loop
begin
-- Note that name has %b on the end which we ignore
- -- First we output the initial _ada_ since we know that the main
- -- program is a library level subprogram.
+ -- First we output the initial _ada_ since we know that the main program
+ -- is a library level subprogram.
Set_String ("_ada_");
procedure Set_String (S : String) is
begin
- Statement_Buffer (Last + 1 .. Last + S'Length) := S;
- Last := Last + S'Length;
+ Statement_Buffer (Stm_Last + 1 .. Stm_Last + S'Length) := S;
+ Stm_Last := Stm_Last + S'Length;
end Set_String;
------------------------
procedure Set_String_Replace (S : String) is
begin
- Statement_Buffer (Last - S'Length + 1 .. Last) := S;
+ Statement_Buffer (Stm_Last - S'Length + 1 .. Stm_Last) := S;
end Set_String_Replace;
-------------------
procedure Write_Statement_Buffer is
begin
- WBI (Statement_Buffer (1 .. Last));
- Last := 0;
+ WBI (Statement_Buffer (1 .. Stm_Last));
+ Stm_Last := 0;
end Write_Statement_Buffer;
procedure Write_Statement_Buffer (S : String) is
projects / gcc.git / commitdiff