Skip to content

R
riscv-gcc-1
Commit 354ae449 by Arnaud Charlet
Options

[multiple changes] 

2017-01-13  Javier Miranda  <miranda@adacore.com>

	* einfo.ads (Component_Bit_Offset): Fix documentation.
	* sem_ch13.adb (Check_Record_Representation_Clause): Skip check
	on record holes for components with unknown compile-time offsets.

2017-01-13  Bob Duff  <duff@adacore.com>

	* ali.ads, ali.adb (Static_Elaboration_Model_Used): Remove unused flag.
	* g-locfil.ads: Minor comment fix.

2017-01-13  Bob Duff  <duff@adacore.com>

	* binde.adb (Elab_New): New elaboration order algorithm
	that is expected to cause fewer ABE issues. This is a work in
	progress. The new algorithm is currently disabled, and can be
	enable by the -dp switch, or by modifying the Do_Old and Do_New
	etc. flags and rebuilding. Experimental code is included to
	compare the results of the old and new algorithms.
	* binde.ads: Use GNAT.Dynamic_Tables instead of Table, so we
	can have multiple of these tables, so the old and new algorithms
	can coexist.
	* bindgen.ads (Gen_Output_File): Pass Elab_Order as an 'in'
	parameter of type array. This avoids the global variable, and
	allows bounds checking (which is normally defeated by the tables
	packages). It also ensures that the Elab_Order is read-only
	to Bindgen.
	* bindgen.adb: Pass Elab_Order as an 'in' parameter to all
	subprograms that need it, as above.
	* debug.adb: Document new -dp switch. Modify doc of old -do
	switch.
	* gnatbind.adb (Gnatbind): Make use of new interfaces to Binde
	and Bindgen.  Move writing of closure (-R and -Ra switches)
	to Binde; that's more convenient.

2017-01-13  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Analyze_Expression_Function): If the expression
	function is a completion, all entities referenced in the
	expression are frozen. As a consequence, a reference to an
	uncompleted private type from an enclosing scope is illegal.

From-SVN: r244419
parent 448a1eb3
Showing with 1939 additions and 709 deletions
gcc/ada/ChangeLog
2017-01-13 Javier Miranda <miranda@adacore.com> 2017-01-13 Javier Miranda <miranda@adacore.com>
* einfo.ads (Component_Bit_Offset): Fix documentation.
* sem_ch13.adb (Check_Record_Representation_Clause): Skip check
on record holes for components with unknown compile-time offsets.
2017-01-13 Bob Duff <duff@adacore.com>
* ali.ads, ali.adb (Static_Elaboration_Model_Used): Remove unused flag.
* g-locfil.ads: Minor comment fix.
2017-01-13 Bob Duff <duff@adacore.com>
* binde.adb (Elab_New): New elaboration order algorithm
that is expected to cause fewer ABE issues. This is a work in
progress. The new algorithm is currently disabled, and can be
enable by the -dp switch, or by modifying the Do_Old and Do_New
etc. flags and rebuilding. Experimental code is included to
compare the results of the old and new algorithms.
* binde.ads: Use GNAT.Dynamic_Tables instead of Table, so we
can have multiple of these tables, so the old and new algorithms
can coexist.
* bindgen.ads (Gen_Output_File): Pass Elab_Order as an 'in'
parameter of type array. This avoids the global variable, and
allows bounds checking (which is normally defeated by the tables
packages). It also ensures that the Elab_Order is read-only
to Bindgen.
* bindgen.adb: Pass Elab_Order as an 'in' parameter to all
subprograms that need it, as above.
* debug.adb: Document new -dp switch. Modify doc of old -do
switch.
* gnatbind.adb (Gnatbind): Make use of new interfaces to Binde
and Bindgen. Move writing of closure (-R and -Ra switches)
to Binde; that's more convenient.
2017-01-13 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Analyze_Expression_Function): If the expression
function is a completion, all entities referenced in the
expression are frozen. As a consequence, a reference to an
uncompleted private type from an enclosing scope is illegal.
2017-01-13 Javier Miranda <miranda@adacore.com>
* sem_ch6.adb (Freeze_Expr_Types): New subprogram. * sem_ch6.adb (Freeze_Expr_Types): New subprogram.
(Analyze_Subprogram_Body_Helper): At the occurrence of an (Analyze_Subprogram_Body_Helper): At the occurrence of an
expression function declaration that is a completion, its expression function declaration that is a completion, its
......
gcc/ada/ali.adb
...@@ -116,7 +116,6 @@ package body ALI is ...@@ -116,7 +116,6 @@ package body ALI is
Partition_Elaboration_Policy_Specified := ' '; Partition_Elaboration_Policy_Specified := ' ';
Queuing_Policy_Specified := ' '; Queuing_Policy_Specified := ' ';
SSO_Default_Specified := False; SSO_Default_Specified := False;
Static_Elaboration_Model_Used := False;
Task_Dispatching_Policy_Specified := ' '; Task_Dispatching_Policy_Specified := ' ';
Unreserve_All_Interrupts_Specified := False; Unreserve_All_Interrupts_Specified := False;
Frontend_Exceptions_Specified := False; Frontend_Exceptions_Specified := False;
...@@ -1996,14 +1995,6 @@ package body ALI is ...@@ -1996,14 +1995,6 @@ package body ALI is
Skip_Eol; Skip_Eol;
-- Check if static elaboration model used
if not Units.Table (Units.Last).Dynamic_Elab
and then not Units.Table (Units.Last).Internal
then
Static_Elaboration_Model_Used := True;
end if;
C := Getc; C := Getc;
-- Scan out With lines for this unit -- Scan out With lines for this unit
......
gcc/ada/ali.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -523,11 +523,6 @@ package ALI is ...@@ -523,11 +523,6 @@ package ALI is
-- Set to True if at least one ALI file contains '-fstack-check' in its -- Set to True if at least one ALI file contains '-fstack-check' in its
-- argument list. -- argument list.
Static_Elaboration_Model_Used : Boolean := False;
-- Set to False by Initialize_ALI. Set to True if any ALI file for a
-- non-internal unit compiled with the static elaboration model is
-- encountered.
Task_Dispatching_Policy_Specified : Character := ' '; Task_Dispatching_Policy_Specified : Character := ' ';
-- Set to blank by Initialize_ALI. Set to the appropriate task dispatching -- Set to blank by Initialize_ALI. Set to the appropriate task dispatching
-- policy character if an ali file contains a P line setting the -- policy character if an ali file contains a P line setting the
......
gcc/ada/binde.adb
...@@ -27,22 +27,71 @@ with Binderr; use Binderr; ...@@ -27,22 +27,71 @@ with Binderr; use Binderr;
with Butil; use Butil; with Butil; use Butil;
with Debug; use Debug; with Debug; use Debug;
with Fname; use Fname; with Fname; use Fname;
with Namet; use Namet;
with Opt; use Opt; with Opt; use Opt;
with Osint; with Osint;
with Output; use Output; with Output; use Output;
with Table;
with System.Case_Util; use System.Case_Util; with System.Case_Util; use System.Case_Util;
with System.OS_Lib; with System.OS_Lib;
package body Binde is 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 -- The following data structures are used to represent the graph that is
-- used to determine the elaboration order (using a topological sort). -- used to determine the elaboration order (using a topological sort).
-- The following structures are used to record successors. If A is a -- The following structures are used to record successors. If B is a
-- successor of B in this table, it means that A must be elaborated -- successor of A in this table, it means that A must be elaborated before
-- before B is elaborated. -- 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; type Successor_Id is new Nat;
-- Identification of single successor entry -- Identification of single successor entry
...@@ -68,24 +117,24 @@ package body Binde is ...@@ -68,24 +117,24 @@ package body Binde is
-- order file. -- order file.
Elab, Elab,
-- After directly mentions Before in a pragma Elaborate, so the -- After directly mentions Before in a pragma Elaborate, so the body of
-- body of Before must be elaborated before After is elaborated. -- Before must be elaborated before After is elaborated.
Elab_All, Elab_All,
-- After either mentions Before directly in a pragma Elaborate_All, -- After either mentions Before directly in a pragma Elaborate_All, or
-- or mentions a third unit, X, which itself requires that Before be -- mentions a third unit, X, which itself requires that Before be
-- elaborated before unit X is elaborated. The Elab_All_Link list -- elaborated before unit X is elaborated. The Elab_All_Link list traces
-- traces the dependencies in the latter case. -- the dependencies in the latter case.
Elab_All_Desirable, Elab_All_Desirable,
-- This is just like Elab_All, except that the Elaborate_All was not -- This is just like Elab_All, except that the Elaborate_All was not
-- explicitly present in the source, but rather was created by the -- explicitly present in the source, but rather was created by the front
-- front end, which decided that it was "desirable". -- end, which decided that it was "desirable".
Elab_Desirable, Elab_Desirable,
-- This is just like Elab, except that the Elaborate was not -- This is just like Elab, except that the Elaborate was not explicitly
-- explicitly present in the source, but rather was created by the -- present in the source, but rather was created by the front end, which
-- front end, which decided that it was "desirable". -- decided that it was "desirable".
Spec_First); Spec_First);
-- After is a body, and Before is the corresponding spec -- After is a body, and Before is the corresponding spec
...@@ -115,9 +164,8 @@ package body Binde is ...@@ -115,9 +164,8 @@ package body Binde is
Elab_All_Link : Elab_All_Id; Elab_All_Link : Elab_All_Id;
-- If Reason = Elab_All or Elab_Desirable, then this points to the -- 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. -- chain resulting in this particular dependency.
end record; end record;
-- Note on handling of Elaborate_Body. Basically, if we have a pragma -- Note on handling of Elaborate_Body. Basically, if we have a pragma
...@@ -132,8 +180,8 @@ package body Binde is ...@@ -132,8 +180,8 @@ package body Binde is
Succ_First : constant := 1; Succ_First : constant := 1;
package Succ is new Table.Table ( package Succ is new Table.Table
Table_Component_Type => Successor_Link, (Table_Component_Type => Successor_Link,
Table_Index_Type => Successor_Id, Table_Index_Type => Successor_Id,
Table_Low_Bound => Succ_First, Table_Low_Bound => Succ_First,
Table_Initial => 500, Table_Initial => 500,
...@@ -141,8 +189,8 @@ package body Binde is ...@@ -141,8 +189,8 @@ package body Binde is
Table_Name => "Succ"); Table_Name => "Succ");
-- For the case of Elaborate_All, the following table is used to record -- 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 -- chains of with relationships that lead to the Elab_All link. These are
-- are used solely for diagnostic purposes -- used solely for diagnostic purposes
type Elab_All_Entry is record type Elab_All_Entry is record
Needed_By : Unit_Name_Type; Needed_By : Unit_Name_Type;
...@@ -153,45 +201,69 @@ package body Binde is ...@@ -153,45 +201,69 @@ package body Binde is
-- Link to next entry on chain (No_Elab_All_Link marks end of list) -- Link to next entry on chain (No_Elab_All_Link marks end of list)
end record; end record;
package Elab_All_Entries is new Table.Table ( package Elab_All_Entries is new Table.Table
Table_Component_Type => Elab_All_Entry, (Table_Component_Type => Elab_All_Entry,
Table_Index_Type => Elab_All_Id, Table_Index_Type => Elab_All_Id,
Table_Low_Bound => 1, Table_Low_Bound => 1,
Table_Initial => 2000, Table_Initial => 2000,
Table_Increment => 200, Table_Increment => 200,
Table_Name => "Elab_All_Entries"); 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; Successors : Successor_Id;
-- Pointer to list of links for successor nodes -- Pointer to list of links for successor nodes
Num_Pred : Int; Num_Pred : Int;
-- Number of predecessors for this unit. Normally non-negative, but -- Number of predecessors for this unit that have not yet been chosen.
-- can go negative in the case of units chosen by the diagnose error -- Normally non-negative, but can go negative in the case of units
-- procedure (when cycles are being removed from the graph). -- chosen by the diagnose error procedure (when cycles are being removed
-- from the graph).
Nextnp : Unit_Id; Nextnp : Unit_Id;
-- Forward pointer for list of units with no predecessors -- Forward pointer for list of units with no predecessors
Elab_Order : Nat;
-- Position in elaboration order (zero = not placed yet)
Visited : Boolean; Visited : Boolean;
-- Used in computing transitive closure for Elaborate_All and -- Used in computing transitive closure for Elaborate_All and also in
-- also in locating cycles and paths in the diagnose routines. -- locating cycles and paths in the diagnose routines.
Elab_Position : Natural; Elab_Position : Natural;
-- Initialized to zero. Set non-zero when a unit is chosen and -- Initialized to zero. Set non-zero when a unit is chosen and placed in
-- placed in the elaboration order. The value represents the -- the elaboration order. The value represents the ordinal position in
-- ordinal position in the elaboration order. -- 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; end record;
package UNR is new Table.Table ( package UNR is new Table.Table
Table_Component_Type => Unit_Node_Record, (Table_Component_Type => Unit_Node_Record,
Table_Index_Type => Unit_Id, Table_Index_Type => Unit_Id,
Table_Low_Bound => First_Unit_Entry, Table_Low_Bound => First_Unit_Entry,
Table_Initial => 500, Table_Initial => 500,
...@@ -205,17 +277,26 @@ package body Binde is ...@@ -205,17 +277,26 @@ package body Binde is
-- Number of entries not yet dealt with -- Number of entries not yet dealt with
Cur_Unit : Unit_Id; Cur_Unit : Unit_Id;
-- Current unit, set by Gather_Dependencies, and picked up in Build_Link -- Current unit, set by Gather_Dependencies, and picked up in Build_Link to
-- to set the Reason_Unit field of the created dependency link. -- 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 -- Number of units chosen in the elaboration order so far
----------------------- -----------------------
-- Local Subprograms -- -- 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 -- 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 -- 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 -- than U2, i.e. should be elaborated in preference to U2, based on a set
...@@ -223,6 +304,18 @@ package body Binde is ...@@ -223,6 +304,18 @@ package body Binde is
-- for details). The result is True if U1 is a better choice than U2, and -- 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. -- 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 procedure Build_Link
(Before : Unit_Id; (Before : Unit_Id;
After : Unit_Id; After : Unit_Id;
...@@ -232,7 +325,7 @@ package body Binde is ...@@ -232,7 +325,7 @@ package body Binde is
-- the reason for the link is R. Ea_Id is the contents to be placed in the -- the reason for the link is R. Ea_Id is the contents to be placed in the
-- Elab_All_Link of the entry. -- 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 -- Chosen is the next entry chosen in the elaboration order. This procedure
-- updates all data structures appropriately. -- updates all data structures appropriately.
...@@ -248,7 +341,8 @@ package body Binde is ...@@ -248,7 +341,8 @@ package body Binde is
-- the unit id of the spec. It is an error to call this routine with a unit -- 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. -- 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 -- Called when no elaboration order can be found. Outputs an appropriate
-- diagnosis of the problem, and then abandons the bind. -- diagnosis of the problem, and then abandons the bind.
...@@ -279,6 +373,9 @@ package body Binde is ...@@ -279,6 +373,9 @@ package body Binde is
procedure Gather_Dependencies; procedure Gather_Dependencies;
-- Compute dependencies, building the Succ and UNR tables -- 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; function Is_Body_Unit (U : Unit_Id) return Boolean;
pragma Inline (Is_Body_Unit); pragma Inline (Is_Body_Unit);
-- Determines if given unit is a body -- Determines if given unit is a body
...@@ -297,16 +394,14 @@ package body Binde is ...@@ -297,16 +394,14 @@ package body Binde is
Link : Elab_All_Id) return Elab_All_Id; Link : Elab_All_Id) return Elab_All_Id;
-- Make an Elab_All_Entries table entry with the given Unam and Link -- 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; function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id;
-- This function uses the Info field set in the names table to obtain -- This function uses the Info field set in the names table to obtain
-- the unit Id of a unit, given its name id value. -- 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; procedure Write_Dependencies;
-- Write out dependencies (called only if appropriate option is set) -- Write out dependencies (called only if appropriate option is set)
...@@ -314,17 +409,79 @@ package body Binde is ...@@ -314,17 +409,79 @@ package body Binde is
-- If the reason for the link S is Elaborate_All or Elaborate_Desirable, -- If the reason for the link S is Elaborate_All or Elaborate_Desirable,
-- then this routine will output the "needed by" explanation chain. -- 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 -- -- 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); UT1 : Unit_Record renames Units.Table (U1);
UT2 : Unit_Record renames Units.Table (U2); UT2 : Unit_Record renames Units.Table (U2);
begin begin
if Debug_Flag_B then if Debug_Flag_B then
Write_Str ("Better_Choice ("); Write_Str ("Better_Choice_Optimistic (");
Write_Unit_Name (UT1.Uname); Write_Unit_Name (UT1.Uname);
Write_Str (", "); Write_Str (", ");
Write_Unit_Name (UT2.Uname); Write_Unit_Name (UT2.Uname);
...@@ -381,7 +538,8 @@ package body Binde is ...@@ -381,7 +538,8 @@ package body Binde is
return False; 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) elsif Is_Pure_Or_Preelab_Unit (U1)
and then not and then not
...@@ -419,17 +577,17 @@ package body Binde is ...@@ -419,17 +577,17 @@ package body Binde is
return False; return False;
-- If both are waiting bodies, then prefer the one whose spec is -- If both are waiting bodies, then prefer the one whose spec is more
-- more recently elaborated. Consider the following: -- recently elaborated. Consider the following:
-- spec of A -- spec of A
-- spec of B -- spec of B
-- body of A or B? -- body of A or B?
-- The normal waiting body preference would have placed the body of -- The normal waiting body preference would have placed the body of A
-- A before the spec of B if it could. Since it could not, then it -- before the spec of B if it could. Since it could not, then it must be
-- must be the case that A depends on B. It is therefore a good idea -- the case that A depends on B. It is therefore a good idea to put the
-- to put the body of B first. -- body of B first.
elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
declare declare
...@@ -451,7 +609,7 @@ package body Binde is ...@@ -451,7 +609,7 @@ package body Binde is
-- Remaining choice rules are disabled by Debug flag -do -- 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 -- The following deal with the case of specs that have been marked
-- as Elaborate_Body_Desirable. We generally want to delay these -- as Elaborate_Body_Desirable. We generally want to delay these
...@@ -506,6 +664,41 @@ package body Binde is ...@@ -506,6 +664,41 @@ package body Binde is
end if; end if;
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 -- If we fall through, it means that no preference rule applies, so we
-- use alphabetical order to at least give a deterministic result. -- use alphabetical order to at least give a deterministic result.
...@@ -514,7 +707,226 @@ package body Binde is ...@@ -514,7 +707,226 @@ package body Binde is
end if; end if;
return Uname_Less (UT1.Uname, UT2.Uname); 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 -- -- Build_Link --
...@@ -568,7 +980,8 @@ package body Binde is ...@@ -568,7 +980,8 @@ package body Binde is
-- Choose -- -- 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; S : Successor_Id;
U : Unit_Id; U : Unit_Id;
...@@ -579,17 +992,27 @@ package body Binde is ...@@ -579,17 +992,27 @@ package body Binde is
Write_Eol; Write_Eol;
end if; end if;
-- Add to elaboration order. Note that units having no elaboration -- We shouldn't be choosing something with unelaborated predecessors,
-- code are not treated specially yet. The special casing of this -- and we shouldn't call this twice on the same unit. But that's not
-- is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile -- true when this is called from Diagnose_Elaboration_Problem.
-- we need them here, because the object file list is also driven
-- by the contents of the Elab_Order table. 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; Append (Elab_Order, Chosen);
Elab_Order.Table (Elab_Order.Last) := Chosen;
-- Remove from No_Pred list. This is a little inefficient and may -- Remove from No_Pred list. This is a little inefficient and may be we
-- be we should doubly link the list, but it will do for now. -- should doubly link the list, but it will do for now.
if No_Pred = Chosen then if No_Pred = Chosen then
No_Pred := UNR.Table (Chosen).Nextnp; No_Pred := UNR.Table (Chosen).Nextnp;
...@@ -611,8 +1034,8 @@ package body Binde is ...@@ -611,8 +1034,8 @@ package body Binde is
end loop; end loop;
end if; end if;
-- For all successors, decrement the number of predecessors, and -- For all successors, decrement the number of predecessors, and if it
-- if it becomes zero, then add to no predecessor list. -- becomes zero, then add to no predecessor list.
S := UNR.Table (Chosen).Successors; S := UNR.Table (Chosen).Successors;
while S /= No_Successor loop while S /= No_Successor loop
...@@ -632,31 +1055,47 @@ package body Binde is ...@@ -632,31 +1055,47 @@ package body Binde is
No_Pred := U; No_Pred := U;
end if; end if;
S := Succ.Table (S).Next; if Doing_New and then SCC (U) /= SCC (Chosen) then
end loop; UNR.Table (SCC (U)).SCC_Num_Pred :=
UNR.Table (SCC (U)).SCC_Num_Pred - 1;
-- All done, adjust number of units left count and set elaboration pos 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; Num_Chosen := Num_Chosen + 1;
pragma Assert
(Errors_Detected > 0 or else Num_Chosen = Natural (Last (Elab_Order)));
UNR.Table (Chosen).Elab_Position := Num_Chosen; 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 -- If we just chose a spec with Elaborate_Body set, then we must
-- must immediately elaborate the body, before any other units. -- immediately elaborate the body, before any other units.
if Units.Table (Chosen).Elaborate_Body then if Units.Table (Chosen).Elaborate_Body then
-- If the unit is a spec only, then there is no body. This is a bit -- 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 -- odd given that Elaborate_Body is here, but it is valid in an RCI
-- RCI unit, where we only have the interface in the stub bind. -- unit, where we only have the interface in the stub bind.
if Units.Table (Chosen).Utype = Is_Spec_Only if Units.Table (Chosen).Utype = Is_Spec_Only
and then Units.Table (Chosen).RCI and then Units.Table (Chosen).RCI
then then
null; null;
else else
Choose (Corresponding_Body (Chosen)); Choose (Elab_Order, Corresponding_Body (Chosen));
end if; end if;
end if; end if;
end Choose; end Choose;
...@@ -665,9 +1104,9 @@ package body Binde is ...@@ -665,9 +1104,9 @@ package body Binde is
-- Corresponding_Body -- -- Corresponding_Body --
------------------------ ------------------------
-- Currently if the body and spec are separate, then they appear as -- Currently if the body and spec are separate, then they appear as two
-- two separate units in the same ALI file, with the body appearing -- separate units in the same ALI file, with the body appearing first and
-- first and the spec appearing second. -- the spec appearing second.
function Corresponding_Body (U : Unit_Id) return Unit_Id is function Corresponding_Body (U : Unit_Id) return Unit_Id is
begin begin
...@@ -679,9 +1118,9 @@ package body Binde is ...@@ -679,9 +1118,9 @@ package body Binde is
-- Corresponding_Spec -- -- Corresponding_Spec --
------------------------ ------------------------
-- Currently if the body and spec are separate, then they appear as -- Currently if the body and spec are separate, then they appear as two
-- two separate units in the same ALI file, with the body appearing -- separate units in the same ALI file, with the body appearing first and
-- first and the spec appearing second. -- the spec appearing second.
function Corresponding_Spec (U : Unit_Id) return Unit_Id is function Corresponding_Spec (U : Unit_Id) return Unit_Id is
begin begin
...@@ -689,12 +1128,38 @@ package body Binde is ...@@ -689,12 +1128,38 @@ package body Binde is
return U + 1; return U + 1;
end Corresponding_Spec; 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 -- -- Diagnose_Elaboration_Problem --
---------------------------------- ----------------------------------
procedure Diagnose_Elaboration_Problem is procedure Diagnose_Elaboration_Problem
function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean; (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. -- 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 -- If a path exists, returns True and outputs an appropriate set of
-- error messages giving the path. Also calls Choose for each of the -- error messages giving the path. Also calls Choose for each of the
...@@ -708,7 +1173,11 @@ package body Binde is ...@@ -708,7 +1173,11 @@ package body Binde is
-- Find_Path -- -- 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; function Find_Link (U : Unit_Id; PL : Nat) return Boolean;
-- This is the inner recursive routine, it determines if a path -- This is the inner recursive routine, it determines if a path
-- exists from U to Uto, and if so returns True and outputs the -- exists from U to Uto, and if so returns True and outputs the
...@@ -722,11 +1191,11 @@ package body Binde is ...@@ -722,11 +1191,11 @@ package body Binde is
S : Successor_Id; S : Successor_Id;
begin begin
-- Recursion ends if we are at terminating node and the path -- Recursion ends if we are at terminating node and the path is
-- is sufficiently long, generate error message and return True. -- sufficiently long, generate error message and return True.
if U = Uto and then PL >= ML then if U = Uto and then PL >= ML then
Choose (U); Choose (Elab_Order, U);
return True; return True;
-- All done if already visited -- All done if already visited
...@@ -743,7 +1212,7 @@ package body Binde is ...@@ -743,7 +1212,7 @@ package body Binde is
while S /= No_Successor loop while S /= No_Successor loop
if Find_Link (Succ.Table (S).After, PL + 1) then if Find_Link (Succ.Table (S).After, PL + 1) then
Elab_Error_Msg (S); Elab_Error_Msg (S);
Choose (U); Choose (Elab_Order, U);
return True; return True;
end if; end if;
...@@ -842,9 +1311,9 @@ package body Binde is ...@@ -842,9 +1311,9 @@ package body Binde is
end; end;
end if; end if;
-- Output the header for the error, and manually increment the -- Output the header for the error, and manually increment the error
-- error count. We are using Error_Msg_Output rather than Error_Msg -- count. We are using Error_Msg_Output rather than Error_Msg here for
-- here for two reasons: -- two reasons:
-- This is really only one error, not one for each line -- This is really only one error, not one for each line
-- We want this output on standard output since it is voluminous -- We want this output on standard output since it is voluminous
...@@ -866,8 +1335,8 @@ package body Binde is ...@@ -866,8 +1335,8 @@ package body Binde is
end if; end if;
end loop; end loop;
-- We should never get here, since we were called for some reason, -- We should never get here, since we were called for some reason, and
-- and we should have found and eliminated at least one bad path. -- we should have found and eliminated at least one bad path.
raise Program_Error; raise Program_Error;
end Diagnose_Elaboration_Problem; end Diagnose_Elaboration_Problem;
...@@ -894,14 +1363,14 @@ package body Binde is ...@@ -894,14 +1363,14 @@ package body Binde is
-- Process all units with'ed by Before recursively -- Process all units with'ed by Before recursively
for W in for W in Units.Table (Before).First_With ..
Units.Table (Before).First_With .. Units.Table (Before).Last_With Units.Table (Before).Last_With
loop loop
-- Skip if this with is an interface to a stand-alone library. -- Skip if this with is an interface to a stand-alone library. Skip
-- Skip also if no ALI file for this WITH, happens for language -- also if no ALI file for this WITH, happens for language defined
-- defined generics while bootstrapping the compiler (see body of -- generics while bootstrapping the compiler (see body of routine
-- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited with
-- with clause, which does not impose an elaboration link. -- clause, which does not impose an elaboration link.
if not Withs.Table (W).SAL_Interface if not Withs.Table (W).SAL_Interface
and then Withs.Table (W).Afile /= No_File and then Withs.Table (W).Afile /= No_File
...@@ -922,7 +1391,8 @@ package body Binde is ...@@ -922,7 +1391,8 @@ package body Binde is
Get_Name_String (Withs.Table (W).Uname); Get_Name_String (Withs.Table (W).Uname);
Last_Withed : Natural := Withed'Last; Last_Withed : Natural := Withed'Last;
Withing : String := Withing : String :=
Get_Name_String (Units.Table (Before).Uname); Get_Name_String
(Units.Table (Before).Uname);
Last_Withing : Natural := Withing'Last; Last_Withing : Natural := Withing'Last;
Spec_Body : String := " (Spec)"; Spec_Body : String := " (Spec)";
...@@ -930,20 +1400,20 @@ package body Binde is ...@@ -930,20 +1400,20 @@ package body Binde is
To_Mixed (Withed); To_Mixed (Withed);
To_Mixed (Withing); To_Mixed (Withing);
if Last_Withed > 2 and then if Last_Withed > 2
Withed (Last_Withed - 1) = '%' and then Withed (Last_Withed - 1) = '%'
then then
Last_Withed := Last_Withed - 2; Last_Withed := Last_Withed - 2;
end if; end if;
if Last_Withing > 2 and then if Last_Withing > 2
Withing (Last_Withing - 1) = '%' and then Withing (Last_Withing - 1) = '%'
then then
Last_Withing := Last_Withing - 2; Last_Withing := Last_Withing - 2;
end if; end if;
if Units.Table (Before).Utype = Is_Body or else if Units.Table (Before).Utype = Is_Body
Units.Table (Before).Utype = Is_Body_Only or else Units.Table (Before).Utype = Is_Body_Only
then then
Spec_Body := " (Body)"; Spec_Body := " (Body)";
end if; end if;
...@@ -1059,13 +1529,11 @@ package body Binde is ...@@ -1059,13 +1529,11 @@ package body Binde is
Error_Msg_Unit_1 := Units.Table (SL.Before).Uname; Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
Error_Msg_Unit_2 := Units.Table (SL.After).Uname; Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
Error_Msg_Output Error_Msg_Output
(" $ must therefore be elaborated before $", (" $ must therefore be elaborated before $", True);
True);
Error_Msg_Unit_1 := Units.Table (SL.After).Uname; Error_Msg_Unit_1 := Units.Table (SL.After).Uname;
Error_Msg_Output Error_Msg_Output
(" (because $ has a pragma Elaborate_Body)", (" (because $ has a pragma Elaborate_Body)", True);
True);
end if; end if;
if not Zero_Formatting then if not Zero_Formatting then
...@@ -1077,127 +1545,197 @@ package body Binde is ...@@ -1077,127 +1545,197 @@ package body Binde is
-- Find_Elab_Order -- -- Find_Elab_Order --
--------------------- ---------------------
procedure Find_Elab_Order is procedure Find_Elab_Order
U : Unit_Id; (Elab_Order : out Unit_Id_Table;
Best_So_Far : Unit_Id; 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.
begin -------------------------
Succ.Init; -- Num_Spec_Body_Pairs --
Num_Left := Int (Units.Last - Units.First + 1); -------------------------
-- Initialize unit table for elaboration control function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat is
Result : Nat := 0;
for U in Units.First .. Units.Last loop begin
UNR.Append for J in Order'First + 1 .. Order'Last loop
((Successors => No_Successor, if Units.Table (Order (J - 1)).Utype = Is_Spec
Num_Pred => 0, and then Units.Table (Order (J)).Utype = Is_Body
Nextnp => No_Unit_Id, and then Corresponding_Spec (Order (J)) = Order (J - 1)
Elab_Order => 0, then
Visited => False, Result := Result + 1;
Elab_Position => 0)); end if;
end loop; 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 -- 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 then
Error_Msg ("?use of -p switch questionable"); Error_Msg ("?use of -p switch questionable");
Error_Msg ("?since all units compiled with static elaboration model"); Error_Msg ("?since all units compiled with static elaboration model");
end if; end if;
-- Gather dependencies and output them if option set if Do_New then
if Debug_Flag_V then
Write_Line ("Doing new...");
end if;
Gather_Dependencies; Doing_New := True;
Init;
Elab_New.Find_Elab_Order (Elab_Order);
end if;
-- Output elaboration dependencies if option is set -- 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.
if Elab_Dependency_Output or Debug_Flag_E then if Do_Old
Write_Dependencies; 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 if;
-- Initialize the no predecessor list Doing_New := False;
Init;
No_Pred := No_Unit_Id; Elab_Old.Find_Elab_Order (Old_Elab_Order);
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 if;
end loop;
-- OK, now we determine the elaboration order proper. All we do is to declare
-- select the best choice from the no predecessor list until all the Old_Order : Unit_Id_Array renames
-- nodes have been chosen. 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 pragma Assert (Old_Order'Length = New_Order'Length);
-- done, as indicated by Num_Left being set to zero, or we have pragma Debug (Validate (Old_Order, Doing_New => False));
-- a circularity. In the latter case, diagnose the circularity, pragma Debug (Validate (New_Order, Doing_New => True));
-- removing it from the graph and continue
Get_No_Pred : while No_Pred = No_Unit_Id loop -- Misc debug printouts that can be used for experimentation by
exit Outer when Num_Left < 1; -- changing the 'if's below.
Diagnose_Elaboration_Problem;
end loop Get_No_Pred;
U := No_Pred; if True then
Best_So_Far := No_Unit_Id; 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 True then
if Debug_Flag_N then Write_Str ("Pairs: ");
Write_Str (" considering choice of "); Write_Int (Old_Pairs);
Write_Unit_Name (Units.Table (U).Uname);
Write_Eol;
if Units.Table (U).Elaborate_Body then if Old_Pairs = New_Pairs then
Write_Str Write_Str (" = ");
(" Elaborate_Body = True, Num_Pred for body = "); elsif Old_Pairs < New_Pairs then
Write_Int Write_Str (" < ");
(UNR.Table (Corresponding_Body (U)).Num_Pred);
else else
Write_Str Write_Str (" > ");
(" Elaborate_Body = False");
end if; end if;
Write_Int (New_Pairs);
Write_Eol; Write_Eol;
end if; 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 if Old_Pairs < New_Pairs then
or else ((not Pessimistic_Elab_Order) Write_Str (" < ");
and then Better_Choice (U, Best_So_Far)) else
or else (Pessimistic_Elab_Order Write_Str (" > ");
and then Pessimistic_Better_Choice (U, Best_So_Far)) end if;
then
if Debug_Flag_N then Write_Int (New_Pairs);
Write_Str (" tentatively chosen (best so far)");
Write_Eol; 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; end if;
Best_So_Far := U; -- The Elab_New algorithm doesn't implement the -p switch, so if that
-- was used, use the results from the old algorithm.
if Pessimistic_Elab_Order or Debug_Flag_Old then
New_Order := Old_Order;
end if; end if;
U := UNR.Table (U).Nextnp; -- Now set the Elab_Positions in the Units table. It is important to
exit No_Pred_Search when U = No_Unit_Id; -- do this late, in case we're running both Elab_New and Elab_Old.
end loop No_Pred_Search;
declare
Units_Array : Units.Table_Type renames
Units.Table (Units.First .. Units.Last);
-- If no candididate chosen, it means that no unit has No_Pred = 0, begin
-- but there are units left, hence we have a circular dependency, for J in New_Order'Range loop
-- which we will get Diagnose_Elaboration_Problem to diagnose it. pragma Assert
(UNR.Table (New_Order (J)).Elab_Position = Positive (J));
Units_Array (New_Order (J)).Elab_Position := Positive (J);
end loop;
end;
if Best_So_Far = No_Unit_Id then if Errors_Detected = 0 then
Diagnose_Elaboration_Problem;
-- Otherwise choose the best candidate found -- Display elaboration order if -l was specified
if Elab_Order_Output then
if Zero_Formatting then
Write_Elab_Order (New_Order, Title => "");
else else
Choose (Best_So_Far); Write_Elab_Order (New_Order, Title => "ELABORATION ORDER");
end if; end if;
end loop Outer; 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;
end Find_Elab_Order; end Find_Elab_Order;
---------------------- ----------------------
...@@ -1211,7 +1749,7 @@ package body Binde is ...@@ -1211,7 +1749,7 @@ package body Binde is
function Get_Line return String; function Get_Line return String;
-- Read the next line from the file content read by Read_File. Strip -- 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). -- "%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;
...@@ -1222,6 +1760,7 @@ package body Binde is ...@@ -1222,6 +1760,7 @@ package body Binde is
--------------- ---------------
function Read_File (Name : String) return String_Ptr is function Read_File (Name : String) return String_Ptr is
-- All of the following calls should succeed, because we checked the -- All of the following calls should succeed, because we checked the
-- file in Switch.B, but we double check and raise Program_Error on -- file in Switch.B, but we double check and raise Program_Error on
-- failure, just in case. -- failure, just in case.
...@@ -1363,6 +1902,7 @@ package body Binde is ...@@ -1363,6 +1902,7 @@ package body Binde is
while Cur <= S'Last loop while Cur <= S'Last loop
declare declare
Uname : constant Unit_Name_Type := Name_Find (Get_Line); Uname : constant Unit_Name_Type := Name_Find (Get_Line);
begin begin
if Uname = Empty_Name then if Uname = Empty_Name then
null; -- silently skip blank lines null; -- silently skip blank lines
...@@ -1370,25 +1910,32 @@ package body Binde is ...@@ -1370,25 +1910,32 @@ package body Binde is
elsif Get_Name_Table_Int (Uname) = 0 elsif Get_Name_Table_Int (Uname) = 0
or else Unit_Id (Get_Name_Table_Int (Uname)) = No_Unit_Id or else Unit_Id (Get_Name_Table_Int (Uname)) = No_Unit_Id
then then
if Doing_New then
Write_Line Write_Line
("""" & Get_Name_String (Uname) & ("""" & Get_Name_String (Uname)
""": not present; ignored"); & """: not present; ignored");
end if;
else else
declare declare
Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname); Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname);
begin begin
if Is_Internal_File_Name (Units.Table (Cur_Unit).Sfile) then if Is_Internal_File_Name (Units.Table (Cur_Unit).Sfile) then
if Doing_New then
Write_Line Write_Line
("""" & Get_Name_String (Uname) & ("""" & Get_Name_String (Uname) &
""": predefined unit ignored"); """: predefined unit ignored");
end if;
else else
if Prev_Unit /= No_Unit_Id then if Prev_Unit /= No_Unit_Id then
if Doing_New then
Write_Unit_Name (Units.Table (Prev_Unit).Uname); Write_Unit_Name (Units.Table (Prev_Unit).Uname);
Write_Str (" <-- "); Write_Str (" <-- ");
Write_Unit_Name (Units.Table (Cur_Unit).Uname); Write_Unit_Name (Units.Table (Cur_Unit).Uname);
Write_Eol; Write_Eol;
end if;
Build_Link Build_Link
(Before => Prev_Unit, (Before => Prev_Unit,
...@@ -1419,9 +1966,9 @@ package body Binde is ...@@ -1419,9 +1966,9 @@ package body Binde is
for U in Units.First .. Units.Last loop for U in Units.First .. Units.Last loop
Cur_Unit := U; Cur_Unit := U;
-- If this is not an interface to a stand-alone library and -- If this is not an interface to a stand-alone library and there is
-- there is a body and a spec, then spec must be elaborated first -- a body and a spec, then spec must be elaborated first. Note that
-- Note that the corresponding spec immediately follows the body -- the corresponding spec immediately follows the body.
if not Units.Table (U).SAL_Interface if not Units.Table (U).SAL_Interface
and then Units.Table (U).Utype = Is_Body and then Units.Table (U).Utype = Is_Body
...@@ -1429,12 +1976,13 @@ package body Binde is ...@@ -1429,12 +1976,13 @@ package body Binde is
Build_Link (Corresponding_Spec (U), U, Spec_First); Build_Link (Corresponding_Spec (U), U, Spec_First);
end if; end if;
-- If this unit is not an interface to a stand-alone library, -- If this unit is not an interface to a stand-alone library, process
-- process WITH references for this unit ignoring generic units and -- WITH references for this unit ignoring interfaces to stand-alone
-- interfaces to stand-alone libraries. -- libraries.
if not Units.Table (U).SAL_Interface then 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 loop
if Withs.Table (W).Sfile /= No_File if Withs.Table (W).Sfile /= No_File
and then (not Withs.Table (W).SAL_Interface) and then (not Withs.Table (W).SAL_Interface)
...@@ -1446,9 +1994,12 @@ package body Binde is ...@@ -1446,9 +1994,12 @@ package body Binde is
-- obsolete unit with's a previous (now disappeared) spec. -- obsolete unit with's a previous (now disappeared) spec.
if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then
if Doing_New then
Error_Msg_File_1 := Units.Table (U).Sfile; Error_Msg_File_1 := Units.Table (U).Sfile;
Error_Msg_Unit_1 := Withs.Table (W).Uname; Error_Msg_Unit_1 := Withs.Table (W).Uname;
Error_Msg ("{ depends on $ which no longer exists"); Error_Msg ("{ depends on $ which no longer exists");
end if;
goto Next_With; goto Next_With;
end if; end if;
...@@ -1457,7 +2008,10 @@ package body Binde is ...@@ -1457,7 +2008,10 @@ package body Binde is
-- Pragma Elaborate_All case, for this we use the recursive -- Pragma Elaborate_All case, for this we use the recursive
-- Elab_All_Links procedure to establish the links. -- 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 -- Reset flags used to stop multiple visits to a given
-- node. -- node.
...@@ -1476,8 +2030,9 @@ package body Binde is ...@@ -1476,8 +2030,9 @@ package body Binde is
-- Elaborate_All_Desirable case, for this we establish the -- Elaborate_All_Desirable case, for this we establish the
-- same links as above, but with a different reason. -- 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 -- Reset flags used to stop multiple visits to a given
-- node. -- node.
...@@ -1512,8 +2067,8 @@ package body Binde is ...@@ -1512,8 +2067,8 @@ package body Binde is
(Corresponding_Body (Withed_Unit), U, Elab); (Corresponding_Body (Withed_Unit), U, Elab);
end if; end if;
-- Elaborate_Desirable case, for this we establish -- Elaborate_Desirable case, for this we establish the same
-- the same links as above, but with a different reason. -- links as above, but with a different reason.
elsif Withs.Table (W).Elab_Desirable then elsif Withs.Table (W).Elab_Desirable then
Build_Link (Withed_Unit, U, Withed); Build_Link (Withed_Unit, U, Withed);
...@@ -1550,15 +2105,52 @@ package body Binde is ...@@ -1550,15 +2105,52 @@ package body Binde is
if Force_Elab_Order_File /= null then if Force_Elab_Order_File /= null then
Force_Elab_Order; Force_Elab_Order;
end if; 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; 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 -- -- Is_Body_Unit --
------------------ ------------------
function Is_Body_Unit (U : Unit_Id) return Boolean is function Is_Body_Unit (U : Unit_Id) return Boolean is
begin begin
return Units.Table (U).Utype = Is_Body return
Units.Table (U).Utype = Is_Body
or else Units.Table (U).Utype = Is_Body_Only; or else Units.Table (U).Utype = Is_Body_Only;
end Is_Body_Unit; end Is_Body_Unit;
...@@ -1571,16 +2163,14 @@ package body Binde is ...@@ -1571,16 +2163,14 @@ package body Binde is
-- If we have a body with separate spec, test flags on the spec -- If we have a body with separate spec, test flags on the spec
if Units.Table (U).Utype = Is_Body then if Units.Table (U).Utype = Is_Body then
return Units.Table (Corresponding_Spec (U)).Preelab return
or else Units.Table (Corresponding_Spec (U)).Preelab
Units.Table (Corresponding_Spec (U)).Pure; or else Units.Table (Corresponding_Spec (U)).Pure;
-- Otherwise we have a spec or body acting as spec, test flags on unit -- Otherwise we have a spec or body acting as spec, test flags on unit
else else
return Units.Table (U).Preelab return Units.Table (U).Preelab or else Units.Table (U).Pure;
or else
Units.Table (U).Pure;
end if; end if;
end Is_Pure_Or_Preelab_Unit; end Is_Pure_Or_Preelab_Unit;
...@@ -1590,7 +2180,8 @@ package body Binde is ...@@ -1590,7 +2180,8 @@ package body Binde is
function Is_Waiting_Body (U : Unit_Id) return Boolean is function Is_Waiting_Body (U : Unit_Id) return Boolean is
begin begin
return Units.Table (U).Utype = Is_Body return
Units.Table (U).Utype = Is_Body
and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0; and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
end Is_Waiting_Body; end Is_Waiting_Body;
...@@ -1603,237 +2194,210 @@ package body Binde is ...@@ -1603,237 +2194,210 @@ package body Binde is
Link : Elab_All_Id) return Elab_All_Id Link : Elab_All_Id) return Elab_All_Id
is is
begin begin
Elab_All_Entries.Increment_Last; Elab_All_Entries.Append ((Needed_By => Unam, Next_Elab => Link));
Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam;
Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link;
return Elab_All_Entries.Last; return Elab_All_Entries.Last;
end Make_Elab_All_Entry; end Make_Elab_All_Entry;
------------------------------- ----------------
-- Pessimistic_Better_Choice -- -- Unit_Id_Of --
------------------------------- ----------------
function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean is function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
UT1 : Unit_Record renames Units.Table (U1); Info : constant Int := Get_Name_Table_Int (Uname);
UT2 : Unit_Record renames Units.Table (U2);
begin begin
if Debug_Flag_B then pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
Write_Str ("Pessimistic_Better_Choice ("); return Unit_Id (Info);
Write_Unit_Name (UT1.Uname); end Unit_Id_Of;
Write_Str (", ");
Write_Unit_Name (UT2.Uname);
Write_Line (")");
end if;
-- Note: the checks here are applied in sequence, and the ordering is
-- significant (i.e. the more important criteria are applied first).
-- If either unit is predefined or internal, then we use the normal --------------
-- Better_Choice rule, since we don't want to disturb the elaboration -- Validate --
-- rules of the language with -p, same treatment for Pure/Preelab. --------------
-- Prefer a predefined unit to a non-predefined unit procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean) is
Cur_SCC : Unit_Id := No_Unit_Id;
OK : Boolean := True;
Msg : String := "Old: ";
if UT1.Predefined and then not UT2.Predefined then begin
if Debug_Flag_B then if Doing_New then
Write_Line (" True: u1 is predefined, u2 is not"); Msg := "New: ";
end if; end if;
return True; -- For each unit, assert that its successors are elaborated after it
elsif UT2.Predefined and then not UT1.Predefined then for J in Order'Range loop
if Debug_Flag_B then declare
Write_Line (" False: u2 is predefined, u1 is not"); U : constant Unit_Id := Order (J);
end if; S : Successor_Id := UNR.Table (U).Successors;
return False; 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;
-- Prefer an internal unit to a non-internal unit -- 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.)
elsif UT1.Internal and then not UT2.Internal then if Doing_New then
if Debug_Flag_B then for J in Order'Range loop
Write_Line (" True: u1 is internal, u2 is not"); declare
end if; U : constant Unit_Id := Order (J);
return True; 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;
elsif UT2.Internal and then not UT1.Internal then if Units.Table (U).Utype = Is_Body then
if Debug_Flag_B then if Order (J - 1) /= Corresponding_Spec (U) then
Write_Line (" False: u2 is internal, u1 is not"); OK := False;
Write_Line (Msg & "Bad body with SCC of size 2:");
Write_SCC (SCC (U));
end if;
end if;
end if; end if;
end;
end loop;
return False; -- 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.
-- Prefer a pure or preelaborable unit to one that is not for J in Order'Range loop
declare
U : constant Unit_Id := Order (J);
elsif Is_Pure_Or_Preelab_Unit (U1) begin
and then not if SCC (U) /= Cur_SCC then
Is_Pure_Or_Preelab_Unit (U2) Cur_SCC := SCC (U);
then if UNR.Table (Cur_SCC).Validate_Seen then
if Debug_Flag_B then OK := False;
Write_Line (" True: u1 is pure/preelab, u2 is not"); Write_Line (Msg & "SCC not elaborated together:");
Write_SCC (Cur_SCC);
end if; end if;
return True; UNR.Table (Cur_SCC).Validate_Seen := True;
end if;
elsif Is_Pure_Or_Preelab_Unit (U2) end;
and then not end loop;
Is_Pure_Or_Preelab_Unit (U1)
then
if Debug_Flag_B then
Write_Line (" False: u2 is pure/preelab, u1 is not");
end if; end if;
return False; pragma Assert (OK);
end Validate;
-- Prefer anything else to a waiting body. We want to make bodies wait -------------------
-- as long as possible, till we are forced to choose them. -- Write_Closure --
-------------------
elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then procedure Write_Closure (Order : Unit_Id_Array) is
if Debug_Flag_B then package Closure_Sources is new Table.Table
Write_Line (" False: u1 is waiting body, u2 is not"); (Table_Component_Type => File_Name_Type,
end if; 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
return False; 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.
elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then --------------------
if Debug_Flag_B then -- Put_In_Sources --
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;
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; 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; end if;
end loop;
Closure_Sources.Append (S);
return True; return True;
end Put_In_Sources;
-- If both are waiting bodies, then prefer the one whose spec is -- Local variables
-- less recently elaborated. Consider the following:
-- spec of A Source : File_Name_Type;
-- spec of B
-- body of A or B?
-- The normal waiting body preference would have placed the body of -- Start of processing for Write_Closure
-- 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 begin
if Debug_Flag_B then Closure_Sources.Init;
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; if not Zero_Formatting then
end; Write_Eol;
Write_Str ("REFERENCED SOURCES");
Write_Eol;
end if; end if;
-- Remaining choice rules are disabled by Debug flag -do for J in reverse Order'Range loop
Source := Units.Table (Order (J)).Sfile;
if not Debug_Flag_O then -- Do not include same source more than once
-- The following deal with the case of specs that have been marked if Put_In_Sources (Source)
-- 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 -- Do not include run-time units unless -Ra switch set
-- 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 (List_Closure_All
and then UT2.Elaborate_Body_Desirable or else not Is_Internal_File_Name (Source))
then then
if Debug_Flag_B then if not Zero_Formatting then
Write_Line (" False: u1 is elab body desirable, u2 is not"); Write_Str (" ");
end if; end if;
return False; Write_Str (Get_Name_String (Source));
Write_Eol;
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; end if;
end loop;
return True; -- 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.
-- If we have two specs that are both marked as Elaborate_Body for J in Sdep.First .. Sdep.Last loop
-- desirable, we normally prefer the one whose body is nearer to Source := Sdep.Table (J).Sfile;
-- 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 if Sdep.Table (J).Subunit_Name /= No_Name
and then UT2.Elaborate_Body_Desirable and then Put_In_Sources (Source)
and then not Is_Internal_File_Name (Source)
then then
declare if not Zero_Formatting then
Result : constant Boolean := Write_Str (" ");
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; end if;
return Result; Write_Str (Get_Name_String (Source));
end; Write_Eol;
end if;
end if; end if;
end loop;
-- If we fall through, it means that no preference rule applies, so we if not Zero_Formatting then
-- use alphabetical order to at least give a deterministic result. Since Write_Eol;
-- Pessimistic_Better_Choice is in the business of stirring up the
-- order, we will use reverse alphabetical ordering.
if Debug_Flag_B then
Write_Line (" choose on reverse alpha order");
end if; end if;
end Write_Closure;
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;
------------------------ ------------------------
-- Write_Dependencies -- -- Write_Dependencies --
...@@ -1892,8 +2456,8 @@ package body Binde is ...@@ -1892,8 +2456,8 @@ package body Binde is
else else
Error_Msg_Output Error_Msg_Output
(" which must be elaborated " & (" which must be elaborated along with its "
"along with its spec:", & "spec:",
Info => True); Info => True);
end if; end if;
...@@ -1920,4 +2484,695 @@ package body Binde is ...@@ -1920,4 +2484,695 @@ package body Binde is
end if; end if;
end Write_Elab_All_Chain; 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; end Binde;
gcc/ada/binde.ads
...@@ -23,30 +23,38 @@ ...@@ -23,30 +23,38 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This package contains the routines to determine elaboration order -- This package contains the routine that determines library-level elaboration
-- order.
with ALI; use ALI; with ALI; use ALI;
with Table; with Namet; use Namet;
with Types; use Types; with Types; use Types;
package Binde is with GNAT.Dynamic_Tables;
-- The following table records the chosen elaboration order. It is used package Binde is
-- by Gen_Elab_Calls to generate the sequence of elaboration calls. Note
-- that units are included in this table even if they have no elaboration
-- routine, since the table is also used to drive the generation of object
-- files in the binder output. Gen_Elab_Calls skips any units that have no
-- elaboration routine.
package Elab_Order is new Table.Table ( package Unit_Id_Tables is new GNAT.Dynamic_Tables
Table_Component_Type => Unit_Id, (Table_Component_Type => Unit_Id,
Table_Index_Type => Nat, Table_Index_Type => Nat,
Table_Low_Bound => 1, Table_Low_Bound => 1,
Table_Initial => 500, Table_Initial => 500,
Table_Increment => 200, Table_Increment => 200);
Table_Name => "Elab_Order"); use Unit_Id_Tables;
procedure Find_Elab_Order; subtype Unit_Id_Table is Unit_Id_Tables.Instance;
-- Determine elaboration order subtype Unit_Id_Array is Unit_Id_Tables.Table_Type;
procedure Find_Elab_Order
(Elab_Order : out Unit_Id_Table;
First_Main_Lib_File : File_Name_Type);
-- Determine elaboration order.
--
-- The Elab_Order table records the chosen elaboration order. It is used by
-- Gen_Elab_Calls to generate the sequence of elaboration calls. Note that
-- units are included in this table even if they have no elaboration
-- routine, since the table is also used to drive the generation of object
-- files in the binder output. Gen_Elab_Calls skips any units that have no
-- elaboration routine.
end Binde; end Binde;
gcc/ada/bindgen.adb
...@@ -24,7 +24,6 @@ ...@@ -24,7 +24,6 @@
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
with ALI; use ALI; with ALI; use ALI;
with Binde; use Binde;
with Casing; use Casing; with Casing; use Casing;
with Fname; use Fname; with Fname; use Fname;
with Gnatvsn; use Gnatvsn; with Gnatvsn; use Gnatvsn;
...@@ -47,12 +46,13 @@ with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A; ...@@ -47,12 +46,13 @@ with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
with GNAT.HTable; with GNAT.HTable;
package body Bindgen is package body Bindgen is
use Binde.Unit_Id_Tables;
Statement_Buffer : String (1 .. 1000); Statement_Buffer : String (1 .. 1000);
-- Buffer used for constructing output statements -- Buffer used for constructing output statements
Last : Natural := 0; Stm_Last : Natural := 0;
-- Last location in Statement_Buffer currently set -- Stm_Last location in Statement_Buffer currently set
With_GNARL : Boolean := False; With_GNARL : Boolean := False;
-- Flag which indicates whether the program uses the GNARL library -- Flag which indicates whether the program uses the GNARL library
...@@ -113,8 +113,8 @@ package body Bindgen is ...@@ -113,8 +113,8 @@ package body Bindgen is
-- that the information is consistent across units. The entries -- that the information is consistent across units. The entries
-- in this table are n/u/r/s for not set/user/runtime/system. -- in this table are n/u/r/s for not set/user/runtime/system.
package IS_Pragma_Settings is new Table.Table ( package IS_Pragma_Settings is new Table.Table
Table_Component_Type => Character, (Table_Component_Type => Character,
Table_Index_Type => Int, Table_Index_Type => Int,
Table_Low_Bound => 0, Table_Low_Bound => 0,
Table_Initial => 100, Table_Initial => 100,
...@@ -127,8 +127,8 @@ package body Bindgen is ...@@ -127,8 +127,8 @@ package body Bindgen is
-- The entries in this table are the upper case first character of the -- The entries in this table are the upper case first character of the
-- policy name, e.g. 'F' for FIFO_Within_Priorities. -- policy name, e.g. 'F' for FIFO_Within_Priorities.
package PSD_Pragma_Settings is new Table.Table ( package PSD_Pragma_Settings is new Table.Table
Table_Component_Type => Character, (Table_Component_Type => Character,
Table_Index_Type => Int, Table_Index_Type => Int,
Table_Low_Bound => 0, Table_Low_Bound => 0,
Table_Initial => 100, Table_Initial => 100,
...@@ -271,7 +271,7 @@ package body Bindgen is ...@@ -271,7 +271,7 @@ package body Bindgen is
-- Local Subprograms -- -- Local Subprograms --
----------------------- -----------------------
procedure Gen_Adainit; procedure Gen_Adainit (Elab_Order : Unit_Id_Array);
-- Generates the Adainit procedure -- Generates the Adainit procedure
procedure Gen_Adafinal; procedure Gen_Adafinal;
...@@ -283,27 +283,29 @@ package body Bindgen is ...@@ -283,27 +283,29 @@ package body Bindgen is
procedure Gen_CodePeer_Wrapper; procedure Gen_CodePeer_Wrapper;
-- For CodePeer, generate wrapper which calls user-defined main subprogram -- 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 -- 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 -- 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 -- 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 -- Generate a sequence of finalization calls to elaborated packages
procedure Gen_Main; procedure Gen_Main;
-- Generate procedure 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 -- Output comments containing a list of the full names of the object
-- files to be linked and the list of linker options supplied by -- files to be linked and the list of linker options supplied by
-- Linker_Options pragmas in the source. -- 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 -- Generate Ada output file
procedure Gen_Restrictions; procedure Gen_Restrictions;
...@@ -335,11 +337,11 @@ package body Bindgen is ...@@ -335,11 +337,11 @@ package body Bindgen is
-- the encoding method used for the main program source. If there is no -- the encoding method used for the main program source. If there is no
-- main program source (-z switch used), returns brackets ('b'). -- 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 -- Determine whether the current unit has at least one library-level
-- finalizer. -- 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 -- Compare linker options, when sorting, first according to
-- Is_Internal_File (internal files come later) and then by -- Is_Internal_File (internal files come later) and then by
-- elaboration order position (latest to earliest). -- elaboration order position (latest to earliest).
...@@ -347,21 +349,21 @@ package body Bindgen is ...@@ -347,21 +349,21 @@ package body Bindgen is
procedure Move_Linker_Option (From : Natural; To : Natural); procedure Move_Linker_Option (From : Natural; To : Natural);
-- Move routine for sorting linker options -- 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 -- Set the value of With_GNARL
procedure Set_Char (C : Character); procedure Set_Char (C : Character);
-- Set given character in Statement_Buffer at the Last + 1 position -- Set given character in Statement_Buffer at the Stm_Last + 1 position
-- and increment Last by one to reflect the stored character. -- and increment Stm_Last by one to reflect the stored character.
procedure Set_Int (N : Int); procedure Set_Int (N : Int);
-- Set given value in decimal in Statement_Buffer with no spaces starting -- 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 -- at the Stm_Last + 1 position, and updating Stm_Last past the value. A
-- is output for a negative value. -- minus sign is output for a negative value.
procedure Set_Boolean (B : Boolean); procedure Set_Boolean (B : Boolean);
-- Set given boolean value in Statement_Buffer at the Last + 1 position -- Set given boolean value in Statement_Buffer at the Stm_Last + 1 position
-- and update Last past the value. -- and update Stm_Last past the value.
procedure Set_IS_Pragma_Table; procedure Set_IS_Pragma_Table;
-- Initializes contents of IS_Pragma_Settings table from ALI table -- Initializes contents of IS_Pragma_Settings table from ALI table
...@@ -369,7 +371,7 @@ package body Bindgen is ...@@ -369,7 +371,7 @@ package body Bindgen is
procedure Set_Main_Program_Name; procedure Set_Main_Program_Name;
-- Given the main program name in Name_Buffer (length in Name_Len) generate -- 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 -- 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; procedure Set_Name_Buffer;
-- Set the value stored in positions 1 .. Name_Len of the Name_Buffer -- Set the value stored in positions 1 .. Name_Len of the Name_Buffer
...@@ -379,7 +381,7 @@ package body Bindgen is ...@@ -379,7 +381,7 @@ package body Bindgen is
procedure Set_String (S : String); procedure Set_String (S : String);
-- Sets characters of given string in Statement_Buffer, starting at the -- 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); procedure Set_String_Replace (S : String);
-- Replaces the last S'Length characters in the Statement_Buffer with the -- Replaces the last S'Length characters in the Statement_Buffer with the
...@@ -388,8 +390,8 @@ package body Bindgen is ...@@ -388,8 +390,8 @@ package body Bindgen is
procedure Set_Unit_Name; procedure Set_Unit_Name;
-- Given a unit name in the Name_Buffer, copy it into Statement_Buffer, -- 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. -- starting at the Stm_Last + 1 position and update Stm_Last past the
-- Each dot (.) will be qualified into double underscores (__). -- value. Each dot (.) will be qualified into double underscores (__).
procedure Set_Unit_Number (U : Unit_Id); procedure Set_Unit_Number (U : Unit_Id);
-- Sets unit number (first unit is 1, leading zeroes output to line up all -- Sets unit number (first unit is 1, leading zeroes output to line up all
...@@ -397,11 +399,12 @@ package body Bindgen is ...@@ -397,11 +399,12 @@ package body Bindgen is
-- number of units. -- number of units.
procedure Write_Statement_Buffer; 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); procedure Write_Statement_Buffer (S : String);
-- First writes its argument (using Set_String (S)), then writes out the -- 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); procedure Write_Bind_Line (S : String);
-- Write S (an LF-terminated string) to the binder file (for use with -- Write S (an LF-terminated string) to the binder file (for use with
...@@ -472,7 +475,7 @@ package body Bindgen is ...@@ -472,7 +475,7 @@ package body Bindgen is
-- Gen_Adainit -- -- 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_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU; Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU;
...@@ -892,8 +895,8 @@ package body Bindgen is ...@@ -892,8 +895,8 @@ package body Bindgen is
Write_Statement_Buffer; Write_Statement_Buffer;
end if; end if;
-- Initialize stack limit variable of the environment task if the -- Initialize stack limit variable of the environment task if the stack
-- stack check method is stack limit and stack check is enabled. -- check method is stack limit and stack check is enabled.
if Stack_Check_Limits_On_Target if Stack_Check_Limits_On_Target
and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set) and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
...@@ -934,7 +937,7 @@ package body Bindgen is ...@@ -934,7 +937,7 @@ package body Bindgen is
WBI (""); WBI ("");
end if; end if;
Gen_Elab_Calls; Gen_Elab_Calls (Elab_Order);
if not CodePeer_Mode then if not CodePeer_Mode then
...@@ -980,9 +983,6 @@ package body Bindgen is ...@@ -980,9 +983,6 @@ package body Bindgen is
------------------------- -------------------------
procedure Gen_Bind_Env_String is procedure Gen_Bind_Env_String is
KN, VN : Name_Id := No_Name;
Amp : Character;
procedure Write_Name_With_Len (Nam : Name_Id); procedure Write_Name_With_Len (Nam : Name_Id);
-- Write Nam as a string literal, prefixed with one -- Write Nam as a string literal, prefixed with one
-- character encoding Nam's length. -- character encoding Nam's length.
...@@ -1002,10 +1002,17 @@ package body Bindgen is ...@@ -1002,10 +1002,17 @@ package body Bindgen is
Write_String_Table_Entry (End_String); Write_String_Table_Entry (End_String);
end Write_Name_With_Len; 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 -- Start of processing for Gen_Bind_Env_String
begin begin
Bind_Environment.Get_First (KN, VN); Bind_Environment.Get_First (KN, VN);
if VN = No_Name then if VN = No_Name then
return; return;
end if; end if;
...@@ -1058,15 +1065,15 @@ package body Bindgen is ...@@ -1058,15 +1065,15 @@ package body Bindgen is
-- Gen_Elab_Calls -- -- Gen_Elab_Calls --
-------------------- --------------------
procedure Gen_Elab_Calls is procedure Gen_Elab_Calls (Elab_Order : Unit_Id_Array) is
Check_Elab_Flag : Boolean; Check_Elab_Flag : Boolean;
begin begin
-- Loop through elaboration order entries -- Loop through elaboration order entries
for E in Elab_Order.First .. Elab_Order.Last loop for E in Elab_Order'Range loop
declare declare
Unum : constant Unit_Id := Elab_Order.Table (E); Unum : constant Unit_Id := Elab_Order (E);
U : Unit_Record renames Units.Table (Unum); U : Unit_Record renames Units.Table (Unum);
Unum_Spec : Unit_Id; Unum_Spec : Unit_Id;
...@@ -1241,15 +1248,15 @@ package body Bindgen is ...@@ -1241,15 +1248,15 @@ package body Bindgen is
-- Gen_Elab_Externals -- -- Gen_Elab_Externals --
------------------------ ------------------------
procedure Gen_Elab_Externals is procedure Gen_Elab_Externals (Elab_Order : Unit_Id_Array) is
begin begin
if CodePeer_Mode then if CodePeer_Mode then
return; return;
end if; end if;
for E in Elab_Order.First .. Elab_Order.Last loop for E in Elab_Order'Range loop
declare declare
Unum : constant Unit_Id := Elab_Order.Table (E); Unum : constant Unit_Id := Elab_Order (E);
U : Unit_Record renames Units.Table (Unum); U : Unit_Record renames Units.Table (Unum);
begin begin
...@@ -1289,13 +1296,13 @@ package body Bindgen is ...@@ -1289,13 +1296,13 @@ package body Bindgen is
-- Gen_Elab_Order -- -- Gen_Elab_Order --
-------------------- --------------------
procedure Gen_Elab_Order is procedure Gen_Elab_Order (Elab_Order : Unit_Id_Array) is
begin begin
WBI (" -- BEGIN ELABORATION ORDER"); WBI (" -- BEGIN ELABORATION ORDER");
for J in Elab_Order.First .. Elab_Order.Last loop for J in Elab_Order'Range loop
Set_String (" -- "); Set_String (" -- ");
Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname); Get_Name_String (Units.Table (Elab_Order (J)).Uname);
Set_Name_Buffer; Set_Name_Buffer;
Write_Statement_Buffer; Write_Statement_Buffer;
end loop; end loop;
...@@ -1308,12 +1315,7 @@ package body Bindgen is ...@@ -1308,12 +1315,7 @@ package body Bindgen is
-- Gen_Finalize_Library -- -- Gen_Finalize_Library --
-------------------------- --------------------------
procedure Gen_Finalize_Library is procedure Gen_Finalize_Library (Elab_Order : Unit_Id_Array) is
Count : Int := 1;
U : Unit_Record;
Uspec : Unit_Record;
Unum : Unit_Id;
procedure Gen_Header; procedure Gen_Header;
-- Generate the header of the finalization routine -- Generate the header of the finalization routine
...@@ -1327,6 +1329,13 @@ package body Bindgen is ...@@ -1327,6 +1329,13 @@ package body Bindgen is
WBI (" begin"); WBI (" begin");
end Gen_Header; end Gen_Header;
-- Local variables
Count : Int := 1;
U : Unit_Record;
Uspec : Unit_Record;
Unum : Unit_Id;
-- Start of processing for Gen_Finalize_Library -- Start of processing for Gen_Finalize_Library
begin begin
...@@ -1334,8 +1343,8 @@ package body Bindgen is ...@@ -1334,8 +1343,8 @@ package body Bindgen is
return; return;
end if; end if;
for E in reverse Elab_Order.First .. Elab_Order.Last loop for E in reverse Elab_Order'Range loop
Unum := Elab_Order.Table (E); Unum := Elab_Order (E);
U := Units.Table (Unum); U := Units.Table (Unum);
-- Dealing with package bodies is a little complicated. In such -- Dealing with package bodies is a little complicated. In such
...@@ -1634,11 +1643,11 @@ package body Bindgen is ...@@ -1634,11 +1643,11 @@ package body Bindgen is
end if; end if;
end if; end if;
-- Generate a reference to Ada_Main_Program_Name. This symbol is -- Generate a reference to Ada_Main_Program_Name. This symbol is not
-- not referenced elsewhere in the generated program, but is needed -- referenced elsewhere in the generated program, but is needed by
-- by the debugger (that's why it is generated in the first place). -- the debugger (that's why it is generated in the first place). The
-- The reference stops Ada_Main_Program_Name from being optimized -- reference stops Ada_Main_Program_Name from being optimized away by
-- away by smart linkers, such as the AiX linker. -- smart linkers, such as the AiX linker.
-- Because this variable is unused, we make this variable "aliased" -- Because this variable is unused, we make this variable "aliased"
-- with a pragma Volatile in order to tell the compiler to preserve -- with a pragma Volatile in order to tell the compiler to preserve
...@@ -1664,9 +1673,9 @@ package body Bindgen is ...@@ -1664,9 +1673,9 @@ package body Bindgen is
WBI (" gnat_envp := envp;"); WBI (" gnat_envp := envp;");
WBI (""); WBI ("");
-- If configurable run time and no command line args, then nothing -- If configurable run time and no command line args, then nothing needs
-- needs to be done since the gnat_argc/argv/envp variables are -- to be done since the gnat_argc/argv/envp variables are suppressed in
-- suppressed in this case. -- this case.
elsif Configurable_Run_Time_On_Target then elsif Configurable_Run_Time_On_Target then
null; null;
...@@ -1767,11 +1776,11 @@ package body Bindgen is ...@@ -1767,11 +1776,11 @@ package body Bindgen is
-- Gen_Object_Files_Options -- -- Gen_Object_Files_Options --
------------------------------ ------------------------------
procedure Gen_Object_Files_Options is procedure Gen_Object_Files_Options (Elab_Order : Unit_Id_Array) is
Lgnat : Natural; Lgnat : Natural;
-- This keeps track of the position in the sorted set of entries -- This keeps track of the position in the sorted set of entries in the
-- in the Linker_Options table of where the first entry from an -- Linker_Options table of where the first entry from an internal file
-- internal file appears. -- appears.
Linker_Option_List_Started : Boolean := False; Linker_Option_List_Started : Boolean := False;
-- Set to True when "LINKER OPTION LIST" is displayed -- Set to True when "LINKER OPTION LIST" is displayed
...@@ -1836,17 +1845,17 @@ package body Bindgen is ...@@ -1836,17 +1845,17 @@ package body Bindgen is
Set_List_File (Object_List_Filename.all); Set_List_File (Object_List_Filename.all);
end if; 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 -- If not spec that has an associated body, then generate a comment
-- giving the name of the corresponding object file. -- giving the name of the corresponding object file.
if not Units.Table (Elab_Order.Table (E)).SAL_Interface if not Units.Table (Elab_Order (E)).SAL_Interface
and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec and then Units.Table (Elab_Order (E)).Utype /= Is_Spec
then then
Get_Name_String Get_Name_String
(ALIs.Table (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, -- If the presence of an object file is necessary or if it exists,
-- then use it. -- then use it.
...@@ -1874,6 +1883,7 @@ package body Bindgen is ...@@ -1874,6 +1883,7 @@ package body Bindgen is
for J in 1 .. Nb_Dir_In_Obj_Search_Path loop for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
declare declare
Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J); Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J);
begin begin
Name_Len := 0; Name_Len := 0;
Add_Str_To_Name_Buffer ("-L"); Add_Str_To_Name_Buffer ("-L");
...@@ -1996,7 +2006,10 @@ package body Bindgen is ...@@ -1996,7 +2006,10 @@ package body Bindgen is
-- Gen_Output_File -- -- Gen_Output_File --
--------------------- ---------------------
procedure Gen_Output_File (Filename : String) is procedure Gen_Output_File
(Filename : String;
Elab_Order : Unit_Id_Array)
is
begin begin
-- Acquire settings for Interrupt_State pragmas -- Acquire settings for Interrupt_State pragmas
...@@ -2014,8 +2027,8 @@ package body Bindgen is ...@@ -2014,8 +2027,8 @@ package body Bindgen is
-- Count number of elaboration calls -- Count number of elaboration calls
for E in Elab_Order.First .. Elab_Order.Last loop for E in Elab_Order'Range loop
if Units.Table (Elab_Order.Table (E)).No_Elab then if Units.Table (Elab_Order (E)).No_Elab then
null; null;
else else
Num_Elab_Calls := Num_Elab_Calls + 1; Num_Elab_Calls := Num_Elab_Calls + 1;
...@@ -2024,21 +2037,23 @@ package body Bindgen is ...@@ -2024,21 +2037,23 @@ package body Bindgen is
-- Generate output file in appropriate language -- Generate output file in appropriate language
Gen_Output_File_Ada (Filename); Gen_Output_File_Ada (Filename, Elab_Order);
end Gen_Output_File; end Gen_Output_File;
------------------------- -------------------------
-- Gen_Output_File_Ada -- -- 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; Ada_Main : constant String := Get_Ada_Main_Name;
-- Name to be used for generated Ada main program. See the body of -- 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. -- function Get_Ada_Main_Name for details on the form of the name.
Needs_Library_Finalization : constant Boolean := 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 -- For restricted run-time libraries (ZFP and Ravenscar) tasks are
-- non-terminating, so we do not want finalization. -- non-terminating, so we do not want finalization.
...@@ -2096,7 +2111,7 @@ package body Bindgen is ...@@ -2096,7 +2111,7 @@ package body Bindgen is
WBI ("with System.Secondary_Stack;"); WBI ("with System.Secondary_Stack;");
end if; end if;
Resolve_Binder_Options; Resolve_Binder_Options (Elab_Order);
-- Generate standard with's -- Generate standard with's
...@@ -2240,7 +2255,7 @@ package body Bindgen is ...@@ -2240,7 +2255,7 @@ package body Bindgen is
end if; end if;
Gen_Versions; Gen_Versions;
Gen_Elab_Order; Gen_Elab_Order (Elab_Order);
-- Spec is complete -- Spec is complete
...@@ -2323,7 +2338,7 @@ package body Bindgen is ...@@ -2323,7 +2338,7 @@ package body Bindgen is
-- Generate externals for elaboration entities -- Generate externals for elaboration entities
Gen_Elab_Externals; Gen_Elab_Externals (Elab_Order);
if not CodePeer_Mode then if not CodePeer_Mode then
if not Suppress_Standard_Library_On_Target then if not Suppress_Standard_Library_On_Target then
...@@ -2375,13 +2390,13 @@ package body Bindgen is ...@@ -2375,13 +2390,13 @@ package body Bindgen is
if not Cumulative_Restrictions.Set (No_Finalization) then if not Cumulative_Restrictions.Set (No_Finalization) then
if Needs_Library_Finalization then if Needs_Library_Finalization then
Gen_Finalize_Library; Gen_Finalize_Library (Elab_Order);
end if; end if;
Gen_Adafinal; Gen_Adafinal;
end if; end if;
Gen_Adainit; Gen_Adainit (Elab_Order);
if Bind_Main_Program then if Bind_Main_Program then
Gen_Main; Gen_Main;
...@@ -2389,7 +2404,7 @@ package body Bindgen is ...@@ -2389,7 +2404,7 @@ package body Bindgen is
-- Output object file list and the Ada body is complete -- Output object file list and the Ada body is complete
Gen_Object_Files_Options; Gen_Object_Files_Options (Elab_Order);
WBI (""); WBI ("");
WBI ("end " & Ada_Main & ";"); WBI ("end " & Ada_Main & ";");
...@@ -2519,8 +2534,8 @@ package body Bindgen is ...@@ -2519,8 +2534,8 @@ package body Bindgen is
WBI (" type Version_32 is mod 2 ** 32;"); WBI (" type Version_32 is mod 2 ** 32;");
for U in Units.First .. Units.Last loop for U in Units.First .. Units.Last loop
if not Units.Table (U).SAL_Interface if not Units.Table (U).SAL_Interface
and then and then (not Bind_For_Library
(not Bind_For_Library or else Units.Table (U).Directly_Scanned) or else Units.Table (U).Directly_Scanned)
then then
Increment_Ubuf; Increment_Ubuf;
WBI (" " & Ubuf & " : constant Version_32 := 16#" & WBI (" " & Ubuf & " : constant Version_32 := 16#" &
...@@ -2584,14 +2599,15 @@ package body Bindgen is ...@@ -2584,14 +2599,15 @@ package body Bindgen is
Nlen : Natural; Nlen : Natural;
begin begin
-- For CodePeer, we want reproducible names (independent of other -- For CodePeer, we want reproducible names (independent of other mains
-- mains that may or may not be present) that don't collide -- that may or may not be present) that don't collide when analyzing
-- when analyzing multiple mains and which are easily recognizable -- multiple mains and which are easily recognizable as "ada_main" names.
-- as "ada_main" names.
if CodePeer_Mode then if CodePeer_Mode then
Get_Name_String (Units.Table (First_Unit_Entry).Uname); Get_Name_String (Units.Table (First_Unit_Entry).Uname);
return "ada_main_for_" &
return
"ada_main_for_" &
Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2)); Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2));
end if; end if;
...@@ -2713,13 +2729,13 @@ package body Bindgen is ...@@ -2713,13 +2729,13 @@ package body Bindgen is
-- Has_Finalizer -- -- Has_Finalizer --
------------------- -------------------
function Has_Finalizer return Boolean is function Has_Finalizer (Elab_Order : Unit_Id_Array) return Boolean is
U : Unit_Record; U : Unit_Record;
Unum : Unit_Id; Unum : Unit_Id;
begin begin
for E in reverse Elab_Order.First .. Elab_Order.Last loop for E in reverse Elab_Order'Range loop
Unum := Elab_Order.Table (E); Unum := Elab_Order (E);
U := Units.Table (Unum); U := Units.Table (Unum);
-- We are only interested in non-generic packages -- We are only interested in non-generic packages
...@@ -2749,7 +2765,7 @@ package body Bindgen is ...@@ -2749,7 +2765,7 @@ package body Bindgen is
-- Lt_Linker_Option -- -- 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 begin
-- Sort internal files last -- Sort internal files last
...@@ -2771,7 +2787,6 @@ package body Bindgen is ...@@ -2771,7 +2787,6 @@ package body Bindgen is
return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
> >
Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position; Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position;
end if; end if;
end Lt_Linker_Option; end Lt_Linker_Option;
...@@ -2788,8 +2803,7 @@ package body Bindgen is ...@@ -2788,8 +2803,7 @@ package body Bindgen is
-- Resolve_Binder_Options -- -- 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); procedure Check_Package (Var : in out Boolean; Name : String);
-- Set Var to true iff the current identifier in Namet is Name. Do -- 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 -- nothing if it doesn't match. This procedure is just a helper to
...@@ -2811,8 +2825,8 @@ package body Bindgen is ...@@ -2811,8 +2825,8 @@ package body Bindgen is
-- Start of processing for Resolve_Binder_Options -- Start of processing for Resolve_Binder_Options
begin begin
for E in Elab_Order.First .. Elab_Order.Last loop for E in Elab_Order'Range loop
Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname); Get_Name_String (Units.Table (Elab_Order (E)).Uname);
-- This is not a perfect approach, but is the current protocol -- This is not a perfect approach, but is the current protocol
-- between the run-time and the binder to indicate that tasking is -- between the run-time and the binder to indicate that tasking is
...@@ -2873,15 +2887,18 @@ package body Bindgen is ...@@ -2873,15 +2887,18 @@ package body Bindgen is
----------------- -----------------
procedure Set_Boolean (B : Boolean) is procedure Set_Boolean (B : Boolean) is
True_Str : constant String := "True";
False_Str : constant String := "False"; False_Str : constant String := "False";
True_Str : constant String := "True";
begin begin
if B then if B then
Statement_Buffer (Last + 1 .. Last + True_Str'Length) := True_Str; Statement_Buffer (Stm_Last + 1 .. Stm_Last + True_Str'Length) :=
Last := Last + True_Str'Length; True_Str;
Stm_Last := Stm_Last + True_Str'Length;
else else
Statement_Buffer (Last + 1 .. Last + False_Str'Length) := False_Str; Statement_Buffer (Stm_Last + 1 .. Stm_Last + False_Str'Length) :=
Last := Last + False_Str'Length; False_Str;
Stm_Last := Stm_Last + False_Str'Length;
end if; end if;
end Set_Boolean; end Set_Boolean;
...@@ -2891,8 +2908,8 @@ package body Bindgen is ...@@ -2891,8 +2908,8 @@ package body Bindgen is
procedure Set_Char (C : Character) is procedure Set_Char (C : Character) is
begin begin
Last := Last + 1; Stm_Last := Stm_Last + 1;
Statement_Buffer (Last) := C; Statement_Buffer (Stm_Last) := C;
end Set_Char; end Set_Char;
------------- -------------
...@@ -2910,8 +2927,8 @@ package body Bindgen is ...@@ -2910,8 +2927,8 @@ package body Bindgen is
Set_Int (N / 10); Set_Int (N / 10);
end if; end if;
Last := Last + 1; Stm_Last := Stm_Last + 1;
Statement_Buffer (Last) := Statement_Buffer (Stm_Last) :=
Character'Val (N mod 10 + Character'Pos ('0')); Character'Val (N mod 10 + Character'Pos ('0'));
end if; end if;
end Set_Int; end Set_Int;
...@@ -2951,8 +2968,8 @@ package body Bindgen is ...@@ -2951,8 +2968,8 @@ package body Bindgen is
begin begin
-- Note that name has %b on the end which we ignore -- Note that name has %b on the end which we ignore
-- First we output the initial _ada_ since we know that the main -- First we output the initial _ada_ since we know that the main program
-- program is a library level subprogram. -- is a library level subprogram.
Set_String ("_ada_"); Set_String ("_ada_");
...@@ -3011,8 +3028,8 @@ package body Bindgen is ...@@ -3011,8 +3028,8 @@ package body Bindgen is
procedure Set_String (S : String) is procedure Set_String (S : String) is
begin begin
Statement_Buffer (Last + 1 .. Last + S'Length) := S; Statement_Buffer (Stm_Last + 1 .. Stm_Last + S'Length) := S;
Last := Last + S'Length; Stm_Last := Stm_Last + S'Length;
end Set_String; end Set_String;
------------------------ ------------------------
...@@ -3021,7 +3038,7 @@ package body Bindgen is ...@@ -3021,7 +3038,7 @@ package body Bindgen is
procedure Set_String_Replace (S : String) is procedure Set_String_Replace (S : String) is
begin begin
Statement_Buffer (Last - S'Length + 1 .. Last) := S; Statement_Buffer (Stm_Last - S'Length + 1 .. Stm_Last) := S;
end Set_String_Replace; end Set_String_Replace;
------------------- -------------------
...@@ -3076,8 +3093,8 @@ package body Bindgen is ...@@ -3076,8 +3093,8 @@ package body Bindgen is
procedure Write_Statement_Buffer is procedure Write_Statement_Buffer is
begin begin
WBI (Statement_Buffer (1 .. Last)); WBI (Statement_Buffer (1 .. Stm_Last));
Last := 0; Stm_Last := 0;
end Write_Statement_Buffer; end Write_Statement_Buffer;
procedure Write_Statement_Buffer (S : String) is procedure Write_Statement_Buffer (S : String) is
......
gcc/ada/bindgen.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -32,9 +32,13 @@ ...@@ -32,9 +32,13 @@
-- See the body for exact details of the file that is generated -- See the body for exact details of the file that is generated
with Binde; use Binde;
package Bindgen is package Bindgen is
procedure Gen_Output_File (Filename : String); procedure Gen_Output_File
(Filename : String;
Elab_Order : Unit_Id_Array);
-- Filename is the full path name of the binder output file -- Filename is the full path name of the binder output file
procedure Set_Bind_Env (Key, Value : String); procedure Set_Bind_Env (Key, Value : String);
......
gcc/ada/debug.adb
...@@ -181,14 +181,14 @@ package body Debug is ...@@ -181,14 +181,14 @@ package body Debug is
-- dl -- dl
-- dm -- dm
-- dn List details of manipulation of Num_Pred values -- dn List details of manipulation of Num_Pred values
-- do Use old preference for elaboration order -- do Use older preference for elaboration order
-- dp -- dp Use new preference for elaboration order
-- dq -- dq
-- dr -- dr
-- ds -- ds
-- dt -- dt
-- du List units as they are acquired -- du List units as they are acquired
-- dv -- dv Verbose debugging printouts
-- dw -- dw
-- dx Force binder to read xref information from ali files -- dx Force binder to read xref information from ali files
-- dy -- dy
...@@ -809,14 +809,25 @@ package body Debug is ...@@ -809,14 +809,25 @@ package body Debug is
-- the algorithm used to determine a correct order of elaboration. This -- the algorithm used to determine a correct order of elaboration. This
-- is useful in diagnosing any problems in its behavior. -- is useful in diagnosing any problems in its behavior.
-- do Use old elaboration order preference. The new preference rules -- do Use older elaboration order preference. The new preference rules
-- prefer specs with no bodies to specs with bodies, and between two -- prefer specs with no bodies to specs with bodies, and between two
-- specs with bodies, prefers the one whose body is closer to being -- specs with bodies, prefers the one whose body is closer to being
-- able to be elaborated. This is a clear improvement, but we provide -- able to be elaborated. This is a clear improvement, but we provide
-- this debug flag in case of regressions. -- this debug flag in case of regressions.
-- dp Use new elaboration order preference. The new preference rules
-- elaborate all units within a strongly connected component together,
-- with no other units in between. In particular, if a spec/body pair
-- can be elaborated together, it will be. In the new order, the binder
-- behaves as if every pragma Elaborate_All that would be legal is
-- present, even if it does not appear in the source code. NOTE: We
-- intend to reverse the sense of this switch at some point, so the new
-- preference is the default.
-- du List unit name and file name for each unit as it is read in -- du List unit name and file name for each unit as it is read in
-- dv Verbose debugging printouts
-- dx Force the binder to read (and then ignore) the xref information -- dx Force the binder to read (and then ignore) the xref information
-- in ali files (used to check that read circuit is working OK). -- in ali files (used to check that read circuit is working OK).
......
gcc/ada/einfo.ads
...@@ -670,14 +670,13 @@ package Einfo is ...@@ -670,14 +670,13 @@ package Einfo is
-- stored in a non-standard way, see body for details. -- stored in a non-standard way, see body for details.
-- Component_Bit_Offset (Uint11) -- Component_Bit_Offset (Uint11)
-- Defined in record components (E_Component, E_Discriminant) if a -- Defined in record components (E_Component, E_Discriminant). First
-- component clause applies to the component. First bit position of -- bit position of given component, computed from the first bit and
-- given component, computed from the first bit and position values -- position values given in the component clause. A value of No_Uint
-- given in the component clause. A value of No_Uint means that the -- means that the value is not yet known. The value can be set by the
-- value is not yet known. The value can be set by the appearance of -- appearance of an explicit component clause in a record representation
-- an explicit component clause in a record representation clause, -- clause, or it can be set by the front-end in package Layout, or it can
-- or it can be set by the front-end in package Layout, or it can be -- be set by the backend. By the time backend processing is completed,
-- set by the backend. By the time backend processing is completed,
-- this field is always set. A negative value is used to represent -- this field is always set. A negative value is used to represent
-- a value which is not known at compile time, and must be computed -- a value which is not known at compile time, and must be computed
-- at run-time (this happens if fields of a record have variable -- at run-time (this happens if fields of a record have variable
......
gcc/ada/g-locfil.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1995-2010, AdaCore -- -- Copyright (C) 1995-2016, AdaCore --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -39,7 +39,7 @@ package GNAT.Lock_Files is ...@@ -39,7 +39,7 @@ package GNAT.Lock_Files is
-- Exception raised if file cannot be locked -- Exception raised if file cannot be locked
subtype Path_Name is String; subtype Path_Name is String;
-- Pathname is used by all services provided in this unit to specified -- Pathname is used by all services provided in this unit to specify
-- directory name and file name. On DOS based systems both directory -- directory name and file name. On DOS based systems both directory
-- separators are handled (i.e. slash and backslash). -- separators are handled (i.e. slash and backslash).
......
gcc/ada/gnatbind.adb
...@@ -30,12 +30,10 @@ with Binde; use Binde; ...@@ -30,12 +30,10 @@ with Binde; use Binde;
with Binderr; use Binderr; with Binderr; use Binderr;
with Bindgen; use Bindgen; with Bindgen; use Bindgen;
with Bindusg; with Bindusg;
with Butil; use Butil;
with Casing; use Casing; with Casing; use Casing;
with Csets; with Csets;
with Debug; use Debug; with Debug; use Debug;
with Fmap; with Fmap;
with Fname; use Fname;
with Namet; use Namet; with Namet; use Namet;
with Opt; use Opt; with Opt; use Opt;
with Osint; use Osint; with Osint; use Osint;
...@@ -45,7 +43,6 @@ with Rident; use Rident; ...@@ -45,7 +43,6 @@ with Rident; use Rident;
with Snames; with Snames;
with Switch; use Switch; with Switch; use Switch;
with Switch.B; use Switch.B; with Switch.B; use Switch.B;
with Table;
with Targparm; use Targparm; with Targparm; use Targparm;
with Types; use Types; with Types; use Types;
...@@ -76,22 +73,15 @@ procedure Gnatbind is ...@@ -76,22 +73,15 @@ procedure Gnatbind is
Mapping_File : String_Ptr := null; Mapping_File : String_Ptr := null;
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. Used
-- only with switch -R.
procedure Add_Artificial_ALI_File (Name : String); procedure Add_Artificial_ALI_File (Name : String);
-- Artificially add ALI file Name in the closure -- Artificially add ALI file Name in the closure
function Gnatbind_Supports_Auto_Init return Boolean; function Gnatbind_Supports_Auto_Init return Boolean;
-- Indicates if automatic initialization of elaboration procedure -- Indicates if automatic initialization of elaboration procedure through
-- through the constructor mechanism is possible on the platform. -- the constructor mechanism is possible on the platform.
function Is_Cross_Compiler return Boolean;
-- Returns True iff this is a cross-compiler
procedure List_Applicable_Restrictions; procedure List_Applicable_Restrictions;
-- List restrictions that apply to this partition if option taken -- List restrictions that apply to this partition if option taken
...@@ -110,9 +100,6 @@ procedure Gnatbind is ...@@ -110,9 +100,6 @@ procedure Gnatbind is
procedure Write_Arg (S : String); procedure Write_Arg (S : String);
-- Passed to Generic_Scan_Bind_Args to print args -- Passed to Generic_Scan_Bind_Args to print args
function Is_Cross_Compiler return Boolean;
-- Returns True iff this is a cross-compiler
----------------------------- -----------------------------
-- Add_Artificial_ALI_File -- -- Add_Artificial_ALI_File --
----------------------------- -----------------------------
...@@ -149,6 +136,7 @@ procedure Gnatbind is ...@@ -149,6 +136,7 @@ procedure Gnatbind is
function gnat_binder_supports_auto_init return Integer; function gnat_binder_supports_auto_init return Integer;
pragma Import (C, gnat_binder_supports_auto_init, pragma Import (C, gnat_binder_supports_auto_init,
"__gnat_binder_supports_auto_init"); "__gnat_binder_supports_auto_init");
begin begin
return gnat_binder_supports_auto_init /= 0; return gnat_binder_supports_auto_init /= 0;
end Gnatbind_Supports_Auto_Init; end Gnatbind_Supports_Auto_Init;
...@@ -160,6 +148,7 @@ procedure Gnatbind is ...@@ -160,6 +148,7 @@ procedure Gnatbind is
function Is_Cross_Compiler return Boolean is function Is_Cross_Compiler return Boolean is
Cross_Compiler : Integer; Cross_Compiler : Integer;
pragma Import (C, Cross_Compiler, "__gnat_is_cross_compiler"); pragma Import (C, Cross_Compiler, "__gnat_is_cross_compiler");
begin begin
return Cross_Compiler = 1; return Cross_Compiler = 1;
end Is_Cross_Compiler; end Is_Cross_Compiler;
...@@ -292,8 +281,8 @@ procedure Gnatbind is ...@@ -292,8 +281,8 @@ procedure Gnatbind is
if not Additional_Restrictions_Listed then if not Additional_Restrictions_Listed then
Write_Eol; Write_Eol;
Write_Line Write_Line
("The following additional restrictions may be" & ("The following additional restrictions may be applied to "
" applied to this partition:"); & "this partition:");
Additional_Restrictions_Listed := True; Additional_Restrictions_Listed := True;
end if; end if;
...@@ -301,6 +290,7 @@ procedure Gnatbind is ...@@ -301,6 +290,7 @@ procedure Gnatbind is
declare declare
S : constant String := Restriction_Id'Image (R); S : constant String := Restriction_Id'Image (R);
begin begin
Name_Len := S'Length; Name_Len := S'Length;
Name_Buffer (1 .. Name_Len) := S; Name_Buffer (1 .. Name_Len) := S;
...@@ -377,8 +367,8 @@ procedure Gnatbind is ...@@ -377,8 +367,8 @@ procedure Gnatbind is
else else
Fail Fail
("Prefix of initialization and finalization " & ("Prefix of initialization and finalization procedure names "
"procedure names missing in -L"); & "missing in -L");
end if; end if;
-- -Sin -Slo -Shi -Sxx -Sev -- -Sin -Slo -Shi -Sxx -Sev
...@@ -560,12 +550,12 @@ procedure Gnatbind is ...@@ -560,12 +550,12 @@ procedure Gnatbind is
Write_Str (" " & S); Write_Str (" " & S);
end Write_Arg; end Write_Arg;
procedure Scan_Bind_Args is new Generic_Scan_Bind_Args (Scan_Bind_Arg);
procedure Put_Bind_Args is new Generic_Scan_Bind_Args (Write_Arg);
procedure Check_Version_And_Help is procedure Check_Version_And_Help is
new Check_Version_And_Help_G (Bindusg.Display); new Check_Version_And_Help_G (Bindusg.Display);
procedure Put_Bind_Args is new Generic_Scan_Bind_Args (Write_Arg);
procedure Scan_Bind_Args is new Generic_Scan_Bind_Args (Scan_Bind_Arg);
-- Start of processing for Gnatbind -- Start of processing for Gnatbind
begin begin
...@@ -618,8 +608,8 @@ begin ...@@ -618,8 +608,8 @@ begin
Fail ("switch -a must be used in conjunction with -n or -Lxxx"); Fail ("switch -a must be used in conjunction with -n or -Lxxx");
elsif not Gnatbind_Supports_Auto_Init then elsif not Gnatbind_Supports_Auto_Init then
Fail ("automatic initialisation of elaboration " & Fail ("automatic initialisation of elaboration not supported on this "
"not supported on this platform"); & "platform");
end if; end if;
end if; end if;
...@@ -641,6 +631,7 @@ begin ...@@ -641,6 +631,7 @@ begin
Check_Extensions : declare Check_Extensions : declare
Length : constant Natural := Output_File_Name'Length; Length : constant Natural := Output_File_Name'Length;
Last : constant Natural := Output_File_Name'Last; Last : constant Natural := Output_File_Name'Last;
begin begin
if Length <= 4 if Length <= 4
or else Output_File_Name (Last - 3 .. Last) /= ".adb" or else Output_File_Name (Last - 3 .. Last) /= ".adb"
...@@ -873,132 +864,19 @@ begin ...@@ -873,132 +864,19 @@ begin
-- Complete bind if no errors -- Complete bind if no errors
if Errors_Detected = 0 then if Errors_Detected = 0 then
Find_Elab_Order; declare
Elab_Order : Unit_Id_Table;
if Errors_Detected = 0 then use Unit_Id_Tables;
-- Display elaboration order if -l was specified
if Elab_Order_Output then
if not Zero_Formatting then
Write_Eol;
Write_Str ("ELABORATION ORDER");
Write_Eol;
end if;
for J in Elab_Order.First .. Elab_Order.Last loop
if not Units.Table (Elab_Order.Table (J)).SAL_Interface then
if not Zero_Formatting then
Write_Str (" ");
end if;
Write_Unit_Name
(Units.Table (Elab_Order.Table (J)).Uname);
Write_Eol;
end if;
end loop;
if not Zero_Formatting then
Write_Eol;
end if;
end if;
if not Check_Only then
Gen_Output_File (Output_File_Name.all);
end if;
-- Display list of sources in the closure (except predefined
-- sources) if -R was used.
if List_Closure then
List_Closure_Display : declare
Source : File_Name_Type;
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;
-- Start of processing for List_Closure_Display
begin begin
Closure_Sources.Init; Find_Elab_Order (Elab_Order, First_Main_Lib_File);
if not Zero_Formatting then if Errors_Detected = 0 and then not Check_Only then
Write_Eol; Gen_Output_File
Write_Str ("REFERENCED SOURCES"); (Output_File_Name.all,
Write_Eol; Elab_Order => Elab_Order.Table (First .. Last (Elab_Order)));
end if;
for J in reverse Elab_Order.First .. Elab_Order.Last loop
Source := Units.Table (Elab_Order.Table (J)).Sfile;
-- Do not include same source more than once
if Put_In_Sources (Source)
-- Do not include run-time units unless -Ra switch set
and then (List_Closure_All
or else not Is_Internal_File_Name (Source))
then
if not Zero_Formatting then
Write_Str (" ");
end if;
Write_Str (Get_Name_String (Source));
Write_Eol;
end if;
end loop;
-- 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.
for J in Sdep.First .. Sdep.Last loop
Source := Sdep.Table (J).Sfile;
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;
Write_Str (Get_Name_String (Source));
Write_Eol;
end if;
end loop;
if not Zero_Formatting then
Write_Eol;
end if;
end List_Closure_Display;
end if;
end if; end if;
end;
end if; end if;
Total_Errors := Total_Errors + Errors_Detected; Total_Errors := Total_Errors + Errors_Detected;
...@@ -1010,7 +888,7 @@ begin ...@@ -1010,7 +888,7 @@ begin
Total_Warnings := Total_Warnings + Warnings_Detected; Total_Warnings := Total_Warnings + Warnings_Detected;
end; end;
-- All done. Set proper exit status -- All done. Set the proper exit status.
Finalize_Binderr; Finalize_Binderr;
Namet.Finalize; Namet.Finalize;
......
gcc/ada/sem_ch13.adb
...@@ -10374,15 +10374,26 @@ package body Sem_Ch13 is ...@@ -10374,15 +10374,26 @@ package body Sem_Ch13 is
Nbit := Sbit; Nbit := Sbit;
for J in 1 .. Ncomps loop for J in 1 .. Ncomps loop
CEnt := Comps (J); CEnt := Comps (J);
Error_Msg_Uint_1 := Component_Bit_Offset (CEnt) - Nbit;
declare
CBO : constant Uint := Component_Bit_Offset (CEnt);
begin
-- Skip components with unknown offsets
if CBO /= No_Uint and then CBO >= 0 then
Error_Msg_Uint_1 := CBO - Nbit;
if Error_Msg_Uint_1 > 0 then if Error_Msg_Uint_1 > 0 then
Error_Msg_NE Error_Msg_NE
("?H?^-bit gap before component&", ("?H?^-bit gap before component&",
Component_Name (Component_Clause (CEnt)), CEnt); Component_Name (Component_Clause (CEnt)),
CEnt);
end if; end if;
Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt); Nbit := CBO + Esize (CEnt);
end if;
end;
end loop; end loop;
-- Process variant parts recursively if present -- Process variant parts recursively if present
......
gcc/ada/sem_ch6.adb
...@@ -274,6 +274,7 @@ package body Sem_Ch6 is ...@@ -274,6 +274,7 @@ package body Sem_Ch6 is
New_Spec : Node_Id; New_Spec : Node_Id;
Orig_N : Node_Id; Orig_N : Node_Id;
Ret : Node_Id; Ret : Node_Id;
Ret_Type : Entity_Id;
Prev : Entity_Id; Prev : Entity_Id;
-- If the expression is a completion, Prev is the entity whose -- If the expression is a completion, Prev is the entity whose
...@@ -366,16 +367,34 @@ package body Sem_Ch6 is ...@@ -366,16 +367,34 @@ package body Sem_Ch6 is
then then
Set_Has_Completion (Prev, False); Set_Has_Completion (Prev, False);
Set_Is_Inlined (Prev); Set_Is_Inlined (Prev);
Ret_Type := Etype (Prev);
-- An expression function that is a completion freezes the -- An expression function that is a completion freezes the
-- expression. This means freezing the return type, and if it is -- expression. This means freezing the return type, and if it is an
-- an access type, freezing its designated type as well. -- access type, freezing its designated type as well.
-- Note that we cannot defer this freezing to the analysis of the -- Note that we cannot defer this freezing to the analysis of the
-- expression itself, because a freeze node might appear in a nested -- expression itself, because a freeze node might appear in a nested
-- scope, leading to an elaboration order issue in gigi. -- scope, leading to an elaboration order issue in gigi.
Freeze_Before (N, Etype (Prev)); -- An entity can only be frozen if it has a completion, so we must
-- check this explicitly. If it is declared elsewhere it will have
-- been frozen already, so only types declared in currently opend
-- scopes need to be tested.
if Ekind (Ret_Type) = E_Private_Type
and then In_Open_Scopes (Scope (Ret_Type))
and then not Is_Generic_Type (Ret_Type)
and then not Is_Frozen (Ret_Type)
and then No (Full_View (Ret_Type))
then
Error_Msg_NE
("premature use of private type&",
Result_Definition (Specification (N)), Ret_Type);
else
Freeze_Before (N, Ret_Type);
end if;
if Is_Access_Type (Etype (Prev)) then if Is_Access_Type (Etype (Prev)) then
Freeze_Before (N, Designated_Type (Etype (Prev))); Freeze_Before (N, Designated_Type (Etype (Prev)));
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment