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>
* 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.
(Analyze_Subprogram_Body_Helper): At the occurrence of an
expression function declaration that is a completion, its
......
gcc/ada/ali.adb
......@@ -116,7 +116,6 @@ package body ALI is
Partition_Elaboration_Policy_Specified := ' ';
Queuing_Policy_Specified := ' ';
SSO_Default_Specified := False;
Static_Elaboration_Model_Used := False;
Task_Dispatching_Policy_Specified := ' ';
Unreserve_All_Interrupts_Specified := False;
Frontend_Exceptions_Specified := False;
......@@ -1996,14 +1995,6 @@ package body ALI is
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;
-- Scan out With lines for this unit
......
gcc/ada/ali.ads
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -523,11 +523,6 @@ package ALI is
-- Set to True if at least one ALI file contains '-fstack-check' in its
-- 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 := ' ';
-- Set to blank by Initialize_ALI. Set to the appropriate task dispatching
-- policy character if an ali file contains a P line setting the
......
gcc/ada/binde.adb
......@@ -27,22 +27,71 @@ with Binderr; use Binderr;
with Butil; use Butil;
with Debug; use Debug;
with Fname; use Fname;
with Namet; use Namet;
with Opt; use Opt;
with Osint;
with Output; use Output;
with Table;
with System.Case_Util; use System.Case_Util;
with System.OS_Lib;
package body Binde is
-- We now have Elab_New, a new elaboration-order algorithm. It has the
-- property that ???
--
-- However, any change to elaboration order can break some programs.
-- Therefore, we are keeping the old algorithm in place, to be selected
-- by switches.
--
-- The new algorithm has the following interesting properties:
--
-- * The static and dynamic models use the same elaboration order. The
-- static model might get an error, but if it does not, it will use
-- the same order as the dynamic model.
--
-- * Each SCC (see below) is elaborated together; that is, units from
-- different SCCs are not interspersed.
--
-- * In particular, this implies that if an SCC contains just a spec and
-- the corresponding body, and nothing else, the body will be
-- elaborated immediately after the spec. This is expected to result
-- in a better elaboration order for most programs, because in this
-- case, a call from outside the library unit cannot get ABE.
--
-- * Pragmas Elaborate_All (explicit and implicit) are ignored. Instead,
-- we behave as if every legal pragma Elaborate_All were present. That
-- is, if it would be legal to have "pragma Elaborate_All(Y);" on X,
-- then we behave as if such a pragma exists, even if it does not.
Do_Old : constant Boolean := False;
Do_New : constant Boolean := True;
-- True to enable the old and new algorithms, respectively. Used for
-- debugging/experimentation.
Doing_New : Boolean := False;
-- True if we are currently doing the new algorithm. Print certain
-- messages only when doing the "new" elab order algorithm, so we don't get
-- duplicates. And use different heuristics in Better_Choice_Optimistic.
-- The following data structures are used to represent the graph that is
-- used to determine the elaboration order (using a topological sort).
-- The following structures are used to record successors. If A is a
-- successor of B in this table, it means that A must be elaborated
-- before B is elaborated.
-- The following structures are used to record successors. If B is a
-- successor of A in this table, it means that A must be elaborated before
-- B is elaborated. For example, if Y (body) says "with X;", then Y (body)
-- will be a successor of X (spec), and X (spec) will be a predecessor of
-- Y (body).
--
-- Note that we store the successors of each unit explictly. We don't store
-- the predecessors, but we store a count of them.
--
-- The basic algorithm is to first compute a directed graph of units (type
-- Unit_Node_Record, below), with successors as edges. A unit is "ready"
-- (to be chosen as the next to be elaborated) if it has no predecessors
-- that have not yet been chosen. We use heuristics to decide which of the
-- ready units should be elaborated next, and "choose" that one (which
-- means we append it to the elaboration-order table).
type Successor_Id is new Nat;
-- Identification of single successor entry
......@@ -68,24 +117,24 @@ package body Binde is
-- order file.
Elab,
-- After directly mentions Before in a pragma Elaborate, so the
-- body of Before must be elaborated before After is elaborated.
-- After directly mentions Before in a pragma Elaborate, so the body of
-- Before must be elaborated before After is elaborated.
Elab_All,
-- After either mentions Before directly in a pragma Elaborate_All,
-- or mentions a third unit, X, which itself requires that Before be
-- elaborated before unit X is elaborated. The Elab_All_Link list
-- traces the dependencies in the latter case.
-- After either mentions Before directly in a pragma Elaborate_All, or
-- mentions a third unit, X, which itself requires that Before be
-- elaborated before unit X is elaborated. The Elab_All_Link list traces
-- the dependencies in the latter case.
Elab_All_Desirable,
-- This is just like Elab_All, except that the Elaborate_All was not
-- explicitly present in the source, but rather was created by the
-- front end, which decided that it was "desirable".
-- explicitly present in the source, but rather was created by the front
-- end, which decided that it was "desirable".
Elab_Desirable,
-- This is just like Elab, except that the Elaborate was not
-- explicitly present in the source, but rather was created by the
-- front end, which decided that it was "desirable".
-- This is just like Elab, except that the Elaborate was not explicitly
-- present in the source, but rather was created by the front end, which
-- decided that it was "desirable".
Spec_First);
-- After is a body, and Before is the corresponding spec
......@@ -115,9 +164,8 @@ package body Binde is
Elab_All_Link : Elab_All_Id;
-- If Reason = Elab_All or Elab_Desirable, then this points to the
-- first elment in a list of Elab_All entries that record the with
-- first element in a list of Elab_All entries that record the with
-- chain resulting in this particular dependency.
end record;
-- Note on handling of Elaborate_Body. Basically, if we have a pragma
......@@ -132,8 +180,8 @@ package body Binde is
Succ_First : constant := 1;
package Succ is new Table.Table (
Table_Component_Type => Successor_Link,
package Succ is new Table.Table
(Table_Component_Type => Successor_Link,
Table_Index_Type => Successor_Id,
Table_Low_Bound => Succ_First,
Table_Initial => 500,
......@@ -141,8 +189,8 @@ package body Binde is
Table_Name => "Succ");
-- For the case of Elaborate_All, the following table is used to record
-- chains of with relationships that lead to the Elab_All link. These
-- are used solely for diagnostic purposes
-- chains of with relationships that lead to the Elab_All link. These are
-- used solely for diagnostic purposes
type Elab_All_Entry is record
Needed_By : Unit_Name_Type;
......@@ -153,45 +201,69 @@ package body Binde is
-- Link to next entry on chain (No_Elab_All_Link marks end of list)
end record;
package Elab_All_Entries is new Table.Table (
Table_Component_Type => Elab_All_Entry,
package Elab_All_Entries is new Table.Table
(Table_Component_Type => Elab_All_Entry,
Table_Index_Type => Elab_All_Id,
Table_Low_Bound => 1,
Table_Initial => 2000,
Table_Increment => 200,
Table_Name => "Elab_All_Entries");
-- A Unit_Node record is built for each active unit
type Unit_Id_Array_Ptr is access Unit_Id_Array;
type Unit_Node_Record is record
-- A Unit_Node_Record is built for each active unit
type Unit_Node_Record is record
Successors : Successor_Id;
-- Pointer to list of links for successor nodes
Num_Pred : Int;
-- Number of predecessors for this unit. Normally non-negative, but
-- can go negative in the case of units chosen by the diagnose error
-- procedure (when cycles are being removed from the graph).
-- Number of predecessors for this unit that have not yet been chosen.
-- Normally non-negative, but can go negative in the case of units
-- chosen by the diagnose error procedure (when cycles are being removed
-- from the graph).
Nextnp : Unit_Id;
-- Forward pointer for list of units with no predecessors
Elab_Order : Nat;
-- Position in elaboration order (zero = not placed yet)
Visited : Boolean;
-- Used in computing transitive closure for Elaborate_All and
-- also in locating cycles and paths in the diagnose routines.
-- Used in computing transitive closure for Elaborate_All and also in
-- locating cycles and paths in the diagnose routines.
Elab_Position : Natural;
-- Initialized to zero. Set non-zero when a unit is chosen and
-- placed in the elaboration order. The value represents the
-- ordinal position in the elaboration order.
-- Initialized to zero. Set non-zero when a unit is chosen and placed in
-- the elaboration order. The value represents the ordinal position in
-- the elaboration order.
-- The following are for Elab_New. We compute the strongly connected
-- components (SCCs) of the directed graph of units. The edges are the
-- Successors, which do not include pragmas Elaborate_All (explicit or
-- implicit) in Elab_New. In addition, we assume there is a edge
-- pointing from a body to its corresponding spec; this edge is not
-- included in Successors, because of course a spec is elaborated BEFORE
-- its body, not after.
SCC_Root : Unit_Id;
-- Each unit points to the root of its SCC, which is just an arbitrary
-- member of the SCC. Two units are in the same SCC if and only if their
-- SCC_Roots are equal. U is the root of its SCC if and only if
-- SCC(U)=U.
Nodes : Unit_Id_Array_Ptr;
-- Present only in the root of an SCC. This is the set of units in the
-- SCC, in no particular order.
SCC_Num_Pred : Int;
-- Present only in the root of an SCC. This is the number of predecessor
-- units of the SCC that are in other SCCs, and that have not yet been
-- chosen.
Validate_Seen : Boolean := False;
-- See procedure Validate below
end record;
package UNR is new Table.Table (
Table_Component_Type => Unit_Node_Record,
package UNR is new Table.Table
(Table_Component_Type => Unit_Node_Record,
Table_Index_Type => Unit_Id,
Table_Low_Bound => First_Unit_Entry,
Table_Initial => 500,
......@@ -205,17 +277,26 @@ package body Binde is
-- Number of entries not yet dealt with
Cur_Unit : Unit_Id;
-- Current unit, set by Gather_Dependencies, and picked up in Build_Link
-- to set the Reason_Unit field of the created dependency link.
-- Current unit, set by Gather_Dependencies, and picked up in Build_Link to
-- set the Reason_Unit field of the created dependency link.
Num_Chosen : Natural := 0;
Num_Chosen : Natural;
-- Number of units chosen in the elaboration order so far
-----------------------
-- Local Subprograms --
-----------------------
function Better_Choice (U1, U2 : Unit_Id) return Boolean;
function Debug_Flag_Older return Boolean;
function Debug_Flag_Old return Boolean;
-- True if debug flags select the old or older algorithms
procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean);
-- Assert that certain properties are true
function Better_Choice_Optimistic
(U1 : Unit_Id;
U2 : Unit_Id) return Boolean;
-- U1 and U2 are both permitted candidates for selection as the next unit
-- to be elaborated. This function determines whether U1 is a better choice
-- than U2, i.e. should be elaborated in preference to U2, based on a set
......@@ -223,6 +304,18 @@ package body Binde is
-- for details). The result is True if U1 is a better choice than U2, and
-- False if it is a worse choice, or there is no preference between them.
function Better_Choice_Pessimistic
(U1 : Unit_Id;
U2 : Unit_Id) return Boolean;
-- This is like Better_Choice_Optimistic, and has the same interface, but
-- returns true if U1 is a worse choice than U2 in the sense of the -p
-- (pessimistic elaboration order) switch. We still have to obey Ada rules,
-- so it is not quite the direct inverse of Better_Choice_Optimistic.
function Better_Choice (U1 : Unit_Id; U2 : Unit_Id) return Boolean;
-- Calls Better_Choice_Optimistic or Better_Choice_Pessimistic as
-- appropriate. Also takes care of the U2 = No_Unit_Id case.
procedure Build_Link
(Before : Unit_Id;
After : Unit_Id;
......@@ -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
-- Elab_All_Link of the entry.
procedure Choose (Chosen : Unit_Id);
procedure Choose (Elab_Order : in out Unit_Id_Table; Chosen : Unit_Id);
-- Chosen is the next entry chosen in the elaboration order. This procedure
-- updates all data structures appropriately.
......@@ -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
-- that is not a body, or that does not have a separate spec.
procedure Diagnose_Elaboration_Problem;
procedure Diagnose_Elaboration_Problem
(Elab_Order : in out Unit_Id_Table);
-- Called when no elaboration order can be found. Outputs an appropriate
-- diagnosis of the problem, and then abandons the bind.
......@@ -279,6 +373,9 @@ package body Binde is
procedure Gather_Dependencies;
-- Compute dependencies, building the Succ and UNR tables
procedure Init;
-- Initialize global data structures in this package body
function Is_Body_Unit (U : Unit_Id) return Boolean;
pragma Inline (Is_Body_Unit);
-- Determines if given unit is a body
......@@ -297,16 +394,14 @@ package body Binde is
Link : Elab_All_Id) return Elab_All_Id;
-- Make an Elab_All_Entries table entry with the given Unam and Link
function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean;
-- This is like Better_Choice, and has the same interface, but returns
-- true if U1 is a worse choice than U2 in the sense of the -p (pessimistic
-- elaboration order) switch. We still have to obey Ada rules, so it is
-- not quite the direct inverse of Better_Choice.
function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id;
-- This function uses the Info field set in the names table to obtain
-- the unit Id of a unit, given its name id value.
procedure Write_Closure (Order : Unit_Id_Array);
-- Write the closure. This is for the -R and -Ra switches, "list closure
-- display".
procedure Write_Dependencies;
-- Write out dependencies (called only if appropriate option is set)
......@@ -314,17 +409,79 @@ package body Binde is
-- If the reason for the link S is Elaborate_All or Elaborate_Desirable,
-- then this routine will output the "needed by" explanation chain.
procedure Write_Elab_Order (Order : Unit_Id_Array; Title : String);
-- Display elaboration order. This is for the -l switch. Title is a heading
-- to print; an empty string is passed to indicate Zero_Formatting.
package Elab_New is
-- Implementation of the new algorithm
procedure Write_SCC (U : Unit_Id);
-- Write the unit names of the units in the SCC in which U lives
procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table);
Illegal_Elab_All : Boolean := False;
-- Set true if Find_Elab_Order found an illegal pragma Elaborate_All
-- (explicit or implicit).
function SCC (U : Unit_Id) return Unit_Id;
-- The root of the strongly connected component containing U
function SCC_Num_Pred (U : Unit_Id) return Int;
-- The SCC_Num_Pred of the SCC in which U lives
function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr;
-- The nodes of the strongly connected component containing U
end Elab_New;
use Elab_New;
package Elab_Old is
-- Implementation of the old algorithm
procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table);
end Elab_Old;
-- Most of the code is shared between old and new; such code is outside
-- packages Elab_Old and Elab_New.
-------------------
-- Better_Choice --
-------------------
function Better_Choice (U1, U2 : Unit_Id) return Boolean is
function Better_Choice (U1 : Unit_Id; U2 : Unit_Id) return Boolean is
pragma Assert (U1 /= No_Unit_Id);
begin
if U2 = No_Unit_Id then
return True;
end if;
if Pessimistic_Elab_Order then
return Better_Choice_Pessimistic (U1, U2);
else
return Better_Choice_Optimistic (U1, U2);
end if;
end Better_Choice;
------------------------------
-- Better_Choice_Optimistic --
------------------------------
function Better_Choice_Optimistic
(U1 : Unit_Id;
U2 : Unit_Id) return Boolean
is
UT1 : Unit_Record renames Units.Table (U1);
UT2 : Unit_Record renames Units.Table (U2);
begin
if Debug_Flag_B then
Write_Str ("Better_Choice (");
Write_Str ("Better_Choice_Optimistic (");
Write_Unit_Name (UT1.Uname);
Write_Str (", ");
Write_Unit_Name (UT2.Uname);
......@@ -381,7 +538,8 @@ package body Binde is
return False;
-- Prefer a pure or preelaborable unit to one that is not
-- Prefer a pure or preelaborated unit to one that is not Pure should
-- come before preelaborated.
elsif Is_Pure_Or_Preelab_Unit (U1)
and then not
......@@ -419,17 +577,17 @@ package body Binde is
return False;
-- If both are waiting bodies, then prefer the one whose spec is
-- more recently elaborated. Consider the following:
-- If both are waiting bodies, then prefer the one whose spec is more
-- recently elaborated. Consider the following:
-- spec of A
-- spec of B
-- body of A or B?
-- The normal waiting body preference would have placed the body of
-- A before the spec of B if it could. Since it could not, then it
-- must be the case that A depends on B. It is therefore a good idea
-- to put the body of B first.
-- The normal waiting body preference would have placed the body of A
-- before the spec of B if it could. Since it could not, then it must be
-- the case that A depends on B. It is therefore a good idea to put the
-- body of B first.
elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
declare
......@@ -451,7 +609,7 @@ package body Binde is
-- Remaining choice rules are disabled by Debug flag -do
if not Debug_Flag_O then
if not Debug_Flag_Older then
-- The following deal with the case of specs that have been marked
-- as Elaborate_Body_Desirable. We generally want to delay these
......@@ -506,6 +664,41 @@ package body Binde is
end if;
end if;
-- If we have two specs in the same SCC, choose the one whose body is
-- closer to being ready.
if Doing_New
and then SCC (U1) = SCC (U2)
and then Units.Table (U1).Utype = Is_Spec
and then Units.Table (U2).Utype = Is_Spec
and then UNR.Table (Corresponding_Body (U1)).Num_Pred /=
UNR.Table (Corresponding_Body (U2)).Num_Pred
then
if UNR.Table (Corresponding_Body (U1)).Num_Pred <
UNR.Table (Corresponding_Body (U2)).Num_Pred
then
if Debug_Flag_B then
Write_Str (" True: same SCC; ");
Write_Int (UNR.Table (Corresponding_Body (U1)).Num_Pred);
Write_Str (" < ");
Write_Int (UNR.Table (Corresponding_Body (U2)).Num_Pred);
Write_Eol;
end if;
return True;
else
if Debug_Flag_B then
Write_Str (" False: same SCC; ");
Write_Int (UNR.Table (Corresponding_Body (U1)).Num_Pred);
Write_Str (" > ");
Write_Int (UNR.Table (Corresponding_Body (U2)).Num_Pred);
Write_Eol;
end if;
return False;
end if;
end if;
-- If we fall through, it means that no preference rule applies, so we
-- use alphabetical order to at least give a deterministic result.
......@@ -514,7 +707,226 @@ package body Binde is
end if;
return Uname_Less (UT1.Uname, UT2.Uname);
end Better_Choice;
end Better_Choice_Optimistic;
-------------------------------
-- Better_Choice_Pessimistic --
-------------------------------
function Better_Choice_Pessimistic
(U1 : Unit_Id;
U2 : Unit_Id) return Boolean
is
UT1 : Unit_Record renames Units.Table (U1);
UT2 : Unit_Record renames Units.Table (U2);
begin
if Debug_Flag_B then
Write_Str ("Better_Choice_Pessimistic (");
Write_Unit_Name (UT1.Uname);
Write_Str (", ");
Write_Unit_Name (UT2.Uname);
Write_Line (")");
end if;
-- Note: the checks here are applied in sequence, and the ordering is
-- significant (i.e. the more important criteria are applied first).
-- If either unit is predefined or internal, then we use the normal
-- Better_Choice_Optimistic rule, since we don't want to disturb the
-- elaboration rules of the language with -p, same treatment for
-- Pure/Preelab.
-- Prefer a predefined unit to a non-predefined unit
if UT1.Predefined and then not UT2.Predefined then
if Debug_Flag_B then
Write_Line (" True: u1 is predefined, u2 is not");
end if;
return True;
elsif UT2.Predefined and then not UT1.Predefined then
if Debug_Flag_B then
Write_Line (" False: u2 is predefined, u1 is not");
end if;
return False;
-- Prefer an internal unit to a non-internal unit
elsif UT1.Internal and then not UT2.Internal then
if Debug_Flag_B then
Write_Line (" True: u1 is internal, u2 is not");
end if;
return True;
elsif UT2.Internal and then not UT1.Internal then
if Debug_Flag_B then
Write_Line (" False: u2 is internal, u1 is not");
end if;
return False;
-- Prefer a pure or preelaborated unit to one that is not
elsif Is_Pure_Or_Preelab_Unit (U1)
and then not
Is_Pure_Or_Preelab_Unit (U2)
then
if Debug_Flag_B then
Write_Line (" True: u1 is pure/preelab, u2 is not");
end if;
return True;
elsif Is_Pure_Or_Preelab_Unit (U2)
and then not
Is_Pure_Or_Preelab_Unit (U1)
then
if Debug_Flag_B then
Write_Line (" False: u2 is pure/preelab, u1 is not");
end if;
return False;
-- Prefer anything else to a waiting body. We want to make bodies wait
-- as long as possible, till we are forced to choose them.
elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
if Debug_Flag_B then
Write_Line (" False: u1 is waiting body, u2 is not");
end if;
return False;
elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
if Debug_Flag_B then
Write_Line (" True: u2 is waiting body, u1 is not");
end if;
return True;
-- Prefer a spec to a body (this is mandatory)
elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
if Debug_Flag_B then
Write_Line (" False: u1 is body, u2 is not");
end if;
return False;
elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
if Debug_Flag_B then
Write_Line (" True: u2 is body, u1 is not");
end if;
return True;
-- If both are waiting bodies, then prefer the one whose spec is less
-- recently elaborated. Consider the following:
-- spec of A
-- spec of B
-- body of A or B?
-- The normal waiting body preference would have placed the body of A
-- before the spec of B if it could. Since it could not, then it must be
-- the case that A depends on B. It is therefore a good idea to put the
-- body of B last so that if there is an elaboration order problem, we
-- will find it (that's what pessimistic order is about).
elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
declare
Result : constant Boolean :=
UNR.Table (Corresponding_Spec (U1)).Elab_Position <
UNR.Table (Corresponding_Spec (U2)).Elab_Position;
begin
if Debug_Flag_B then
if Result then
Write_Line (" True: based on waiting body elab positions");
else
Write_Line (" False: based on waiting body elab positions");
end if;
end if;
return Result;
end;
end if;
-- Remaining choice rules are disabled by Debug flag -do
if not Debug_Flag_Older then
-- The following deal with the case of specs that have been marked as
-- Elaborate_Body_Desirable. In the normal case, we generally want to
-- delay the elaboration of these specs as long as possible, so that
-- bodies have better chance of being elaborated closer to the specs.
-- Better_Choice_Pessimistic as usual wants to do the opposite and
-- elaborate such specs as early as possible.
-- If we have two units, one of which is a spec for which this flag
-- is set, and the other is not, we normally prefer to delay the spec
-- for which the flag is set, so again Better_Choice_Pessimistic does
-- the opposite.
if not UT1.Elaborate_Body_Desirable
and then UT2.Elaborate_Body_Desirable
then
if Debug_Flag_B then
Write_Line (" False: u1 is elab body desirable, u2 is not");
end if;
return False;
elsif not UT2.Elaborate_Body_Desirable
and then UT1.Elaborate_Body_Desirable
then
if Debug_Flag_B then
Write_Line (" True: u1 is elab body desirable, u2 is not");
end if;
return True;
-- If we have two specs that are both marked as Elaborate_Body
-- desirable, we normally prefer the one whose body is nearer to
-- being able to be elaborated, based on the Num_Pred count. This
-- helps to ensure bodies are as close to specs as possible. As
-- usual, Better_Choice_Pessimistic does the opposite.
elsif UT1.Elaborate_Body_Desirable
and then UT2.Elaborate_Body_Desirable
then
declare
Result : constant Boolean :=
UNR.Table (Corresponding_Body (U1)).Num_Pred >=
UNR.Table (Corresponding_Body (U2)).Num_Pred;
begin
if Debug_Flag_B then
if Result then
Write_Line (" True based on Num_Pred compare");
else
Write_Line (" False based on Num_Pred compare");
end if;
end if;
return Result;
end;
end if;
end if;
-- If we fall through, it means that no preference rule applies, so we
-- use alphabetical order to at least give a deterministic result. Since
-- Better_Choice_Pessimistic is in the business of stirring up the
-- order, we will use reverse alphabetical ordering.
if Debug_Flag_B then
Write_Line (" choose on reverse alpha order");
end if;
return Uname_Less (UT2.Uname, UT1.Uname);
end Better_Choice_Pessimistic;
----------------
-- Build_Link --
......@@ -568,7 +980,8 @@ package body Binde is
-- Choose --
------------
procedure Choose (Chosen : Unit_Id) is
procedure Choose (Elab_Order : in out Unit_Id_Table; Chosen : Unit_Id) is
pragma Assert (Chosen /= No_Unit_Id);
S : Successor_Id;
U : Unit_Id;
......@@ -579,17 +992,27 @@ package body Binde is
Write_Eol;
end if;
-- Add to elaboration order. Note that units having no elaboration
-- code are not treated specially yet. The special casing of this
-- is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile
-- we need them here, because the object file list is also driven
-- by the contents of the Elab_Order table.
-- We shouldn't be choosing something with unelaborated predecessors,
-- and we shouldn't call this twice on the same unit. But that's not
-- true when this is called from Diagnose_Elaboration_Problem.
if Errors_Detected = 0 then
pragma Assert (UNR.Table (Chosen).Num_Pred = 0);
pragma Assert (UNR.Table (Chosen).Elab_Position = 0);
pragma Assert (not Doing_New or else SCC_Num_Pred (Chosen) = 0);
null;
end if;
-- Add to elaboration order. Note that units having no elaboration code
-- are not treated specially yet. The special casing of this is in
-- Bindgen, where Gen_Elab_Calls skips over them. Meanwhile we need them
-- here, because the object file list is also driven by the contents of
-- the Elab_Order table.
Elab_Order.Increment_Last;
Elab_Order.Table (Elab_Order.Last) := Chosen;
Append (Elab_Order, Chosen);
-- Remove from No_Pred list. This is a little inefficient and may
-- be we should doubly link the list, but it will do for now.
-- Remove from No_Pred list. This is a little inefficient and may be we
-- should doubly link the list, but it will do for now.
if No_Pred = Chosen then
No_Pred := UNR.Table (Chosen).Nextnp;
......@@ -611,8 +1034,8 @@ package body Binde is
end loop;
end if;
-- For all successors, decrement the number of predecessors, and
-- if it becomes zero, then add to no predecessor list.
-- For all successors, decrement the number of predecessors, and if it
-- becomes zero, then add to no predecessor list.
S := UNR.Table (Chosen).Successors;
while S /= No_Successor loop
......@@ -632,31 +1055,47 @@ package body Binde is
No_Pred := U;
end if;
S := Succ.Table (S).Next;
end loop;
if Doing_New and then SCC (U) /= SCC (Chosen) then
UNR.Table (SCC (U)).SCC_Num_Pred :=
UNR.Table (SCC (U)).SCC_Num_Pred - 1;
-- 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_Chosen := Num_Chosen + 1;
pragma Assert
(Errors_Detected > 0 or else Num_Chosen = Natural (Last (Elab_Order)));
UNR.Table (Chosen).Elab_Position := Num_Chosen;
Units.Table (Chosen).Elab_Position := Num_Chosen;
-- If we just chose a spec with Elaborate_Body set, then we
-- must immediately elaborate the body, before any other units.
-- If we just chose a spec with Elaborate_Body set, then we must
-- immediately elaborate the body, before any other units.
if Units.Table (Chosen).Elaborate_Body then
-- If the unit is a spec only, then there is no body. This is a bit
-- odd given that Elaborate_Body is here, but it is valid in an
-- RCI unit, where we only have the interface in the stub bind.
-- odd given that Elaborate_Body is here, but it is valid in an RCI
-- unit, where we only have the interface in the stub bind.
if Units.Table (Chosen).Utype = Is_Spec_Only
and then Units.Table (Chosen).RCI
then
null;
else
Choose (Corresponding_Body (Chosen));
Choose (Elab_Order, Corresponding_Body (Chosen));
end if;
end if;
end Choose;
......@@ -665,9 +1104,9 @@ package body Binde is
-- Corresponding_Body --
------------------------
-- Currently if the body and spec are separate, then they appear as
-- two separate units in the same ALI file, with the body appearing
-- first and the spec appearing second.
-- Currently if the body and spec are separate, then they appear as two
-- separate units in the same ALI file, with the body appearing first and
-- the spec appearing second.
function Corresponding_Body (U : Unit_Id) return Unit_Id is
begin
......@@ -679,9 +1118,9 @@ package body Binde is
-- Corresponding_Spec --
------------------------
-- Currently if the body and spec are separate, then they appear as
-- two separate units in the same ALI file, with the body appearing
-- first and the spec appearing second.
-- Currently if the body and spec are separate, then they appear as two
-- separate units in the same ALI file, with the body appearing first and
-- the spec appearing second.
function Corresponding_Spec (U : Unit_Id) return Unit_Id is
begin
......@@ -689,12 +1128,38 @@ package body Binde is
return U + 1;
end Corresponding_Spec;
--------------------
-- Debug_Flag_Old --
--------------------
function Debug_Flag_Old return Boolean is
begin
-- For now, Debug_Flag_P means "use the new algorithm". Once it is
-- stable, we intend to remove the "not" below.
return not Debug_Flag_P;
end Debug_Flag_Old;
----------------------
-- Debug_Flag_Older --
----------------------
function Debug_Flag_Older return Boolean is
begin
return Debug_Flag_O;
end Debug_Flag_Older;
----------------------------------
-- Diagnose_Elaboration_Problem --
----------------------------------
procedure Diagnose_Elaboration_Problem is
function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean;
procedure Diagnose_Elaboration_Problem
(Elab_Order : in out Unit_Id_Table)
is
function Find_Path
(Ufrom : Unit_Id;
Uto : Unit_Id;
ML : Nat) return Boolean;
-- Recursive routine used to find a path from node Ufrom to node Uto.
-- If a path exists, returns True and outputs an appropriate set of
-- error messages giving the path. Also calls Choose for each of the
......@@ -708,7 +1173,11 @@ package body Binde is
-- Find_Path --
---------------
function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is
function Find_Path
(Ufrom : Unit_Id;
Uto : Unit_Id;
ML : Nat) return Boolean
is
function Find_Link (U : Unit_Id; PL : Nat) return Boolean;
-- This is the inner recursive routine, it determines if a path
-- exists from U to Uto, and if so returns True and outputs the
......@@ -722,11 +1191,11 @@ package body Binde is
S : Successor_Id;
begin
-- Recursion ends if we are at terminating node and the path
-- is sufficiently long, generate error message and return True.
-- Recursion ends if we are at terminating node and the path is
-- sufficiently long, generate error message and return True.
if U = Uto and then PL >= ML then
Choose (U);
Choose (Elab_Order, U);
return True;
-- All done if already visited
......@@ -743,7 +1212,7 @@ package body Binde is
while S /= No_Successor loop
if Find_Link (Succ.Table (S).After, PL + 1) then
Elab_Error_Msg (S);
Choose (U);
Choose (Elab_Order, U);
return True;
end if;
......@@ -842,9 +1311,9 @@ package body Binde is
end;
end if;
-- Output the header for the error, and manually increment the
-- error count. We are using Error_Msg_Output rather than Error_Msg
-- here for two reasons:
-- Output the header for the error, and manually increment the error
-- count. We are using Error_Msg_Output rather than Error_Msg here for
-- two reasons:
-- This is really only one error, not one for each line
-- We want this output on standard output since it is voluminous
......@@ -866,8 +1335,8 @@ package body Binde is
end if;
end loop;
-- We should never get here, since we were called for some reason,
-- and we should have found and eliminated at least one bad path.
-- We should never get here, since we were called for some reason, and
-- we should have found and eliminated at least one bad path.
raise Program_Error;
end Diagnose_Elaboration_Problem;
......@@ -894,14 +1363,14 @@ package body Binde is
-- Process all units with'ed by Before recursively
for W in
Units.Table (Before).First_With .. Units.Table (Before).Last_With
for W in Units.Table (Before).First_With ..
Units.Table (Before).Last_With
loop
-- Skip if this with is an interface to a stand-alone library.
-- Skip also if no ALI file for this WITH, happens for language
-- defined generics while bootstrapping the compiler (see body of
-- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited
-- with clause, which does not impose an elaboration link.
-- Skip if this with is an interface to a stand-alone library. Skip
-- also if no ALI file for this WITH, happens for language defined
-- generics while bootstrapping the compiler (see body of routine
-- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited with
-- clause, which does not impose an elaboration link.
if not Withs.Table (W).SAL_Interface
and then Withs.Table (W).Afile /= No_File
......@@ -922,7 +1391,8 @@ package body Binde is
Get_Name_String (Withs.Table (W).Uname);
Last_Withed : Natural := Withed'Last;
Withing : String :=
Get_Name_String (Units.Table (Before).Uname);
Get_Name_String
(Units.Table (Before).Uname);
Last_Withing : Natural := Withing'Last;
Spec_Body : String := " (Spec)";
......@@ -930,20 +1400,20 @@ package body Binde is
To_Mixed (Withed);
To_Mixed (Withing);
if Last_Withed > 2 and then
Withed (Last_Withed - 1) = '%'
if Last_Withed > 2
and then Withed (Last_Withed - 1) = '%'
then
Last_Withed := Last_Withed - 2;
end if;
if Last_Withing > 2 and then
Withing (Last_Withing - 1) = '%'
if Last_Withing > 2
and then Withing (Last_Withing - 1) = '%'
then
Last_Withing := Last_Withing - 2;
end if;
if Units.Table (Before).Utype = Is_Body or else
Units.Table (Before).Utype = Is_Body_Only
if Units.Table (Before).Utype = Is_Body
or else Units.Table (Before).Utype = Is_Body_Only
then
Spec_Body := " (Body)";
end if;
......@@ -1059,13 +1529,11 @@ package body Binde is
Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
Error_Msg_Output
(" $ must therefore be elaborated before $",
True);
(" $ must therefore be elaborated before $", True);
Error_Msg_Unit_1 := Units.Table (SL.After).Uname;
Error_Msg_Output
(" (because $ has a pragma Elaborate_Body)",
True);
(" (because $ has a pragma Elaborate_Body)", True);
end if;
if not Zero_Formatting then
......@@ -1077,127 +1545,197 @@ package body Binde is
-- Find_Elab_Order --
---------------------
procedure Find_Elab_Order is
U : Unit_Id;
Best_So_Far : Unit_Id;
procedure Find_Elab_Order
(Elab_Order : out Unit_Id_Table;
First_Main_Lib_File : File_Name_Type)
is
function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat;
-- Number of cases where the body of a unit immediately follows the
-- corresponding spec. Such cases are good, because calls to that unit
-- from outside can't get ABE.
begin
Succ.Init;
Num_Left := Int (Units.Last - Units.First + 1);
-------------------------
-- Num_Spec_Body_Pairs --
-------------------------
-- 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
UNR.Append
((Successors => No_Successor,
Num_Pred => 0,
Nextnp => No_Unit_Id,
Elab_Order => 0,
Visited => False,
Elab_Position => 0));
begin
for J in Order'First + 1 .. Order'Last loop
if Units.Table (Order (J - 1)).Utype = Is_Spec
and then Units.Table (Order (J)).Utype = Is_Body
and then Corresponding_Spec (Order (J)) = Order (J - 1)
then
Result := Result + 1;
end if;
end loop;
return Result;
end Num_Spec_Body_Pairs;
-- Local variables
Old_Elab_Order : Unit_Id_Table;
-- Start of processing for Find_Elab_Order
begin
-- Output warning if -p used with no -gnatE units
if Pessimistic_Elab_Order and not Dynamic_Elaboration_Checks_Specified
if Pessimistic_Elab_Order
and not Dynamic_Elaboration_Checks_Specified
then
Error_Msg ("?use of -p switch questionable");
Error_Msg ("?since all units compiled with static elaboration model");
end if;
-- Gather dependencies and output them if option set
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
Write_Dependencies;
if Do_Old
or Pessimistic_Elab_Order
or Debug_Flag_Old
or Illegal_Elab_All
then
if Debug_Flag_V then
Write_Line ("Doing old...");
end if;
-- 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;
Doing_New := False;
Init;
Elab_Old.Find_Elab_Order (Old_Elab_Order);
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.
declare
Old_Order : Unit_Id_Array renames
Old_Elab_Order.Table (1 .. Last (Old_Elab_Order));
New_Order : Unit_Id_Array renames
Elab_Order.Table (1 .. Last (Elab_Order));
Old_Pairs : constant Nat := Num_Spec_Body_Pairs (Old_Order);
New_Pairs : constant Nat := Num_Spec_Body_Pairs (New_Order);
Outer : loop
begin
if Do_Old and Do_New then
Write_Line (Get_Name_String (First_Main_Lib_File));
-- If there are no nodes with predecessors, then either we are
-- done, as indicated by Num_Left being set to zero, or we have
-- a circularity. In the latter case, diagnose the circularity,
-- removing it from the graph and continue
pragma Assert (Old_Order'Length = New_Order'Length);
pragma Debug (Validate (Old_Order, Doing_New => False));
pragma Debug (Validate (New_Order, Doing_New => True));
Get_No_Pred : while No_Pred = No_Unit_Id loop
exit Outer when Num_Left < 1;
Diagnose_Elaboration_Problem;
end loop Get_No_Pred;
-- Misc debug printouts that can be used for experimentation by
-- changing the 'if's below.
U := No_Pred;
Best_So_Far := No_Unit_Id;
if True then
if New_Order = Old_Order then
Write_Line ("Elab_New: same order.");
else
Write_Line ("Elab_New: diff order.");
end if;
end if;
-- Loop to choose best entry in No_Pred list
if New_Order /= Old_Order and then False then
Write_Line ("Elaboration orders differ:");
Write_Elab_Order
(Old_Order, Title => "OLD ELABORATION ORDER");
Write_Elab_Order
(New_Order, Title => "NEW ELABORATION ORDER");
end if;
No_Pred_Search : loop
if Debug_Flag_N then
Write_Str (" considering choice of ");
Write_Unit_Name (Units.Table (U).Uname);
Write_Eol;
if True then
Write_Str ("Pairs: ");
Write_Int (Old_Pairs);
if Units.Table (U).Elaborate_Body then
Write_Str
(" Elaborate_Body = True, Num_Pred for body = ");
Write_Int
(UNR.Table (Corresponding_Body (U)).Num_Pred);
if Old_Pairs = New_Pairs then
Write_Str (" = ");
elsif Old_Pairs < New_Pairs then
Write_Str (" < ");
else
Write_Str
(" Elaborate_Body = False");
Write_Str (" > ");
end if;
Write_Int (New_Pairs);
Write_Eol;
end if;
-- This is a candididate to be considered for choice
if Old_Pairs /= New_Pairs and then False then
Write_Str ("Pairs: ");
Write_Int (Old_Pairs);
if Best_So_Far = No_Unit_Id
or else ((not Pessimistic_Elab_Order)
and then Better_Choice (U, Best_So_Far))
or else (Pessimistic_Elab_Order
and then Pessimistic_Better_Choice (U, Best_So_Far))
then
if Debug_Flag_N then
Write_Str (" tentatively chosen (best so far)");
if Old_Pairs < New_Pairs then
Write_Str (" < ");
else
Write_Str (" > ");
end if;
Write_Int (New_Pairs);
Write_Eol;
if Old_Pairs /= New_Pairs and then Debug_Flag_V then
Write_Elab_Order
(Old_Order, Title => "OLD ELABORATION ORDER");
Write_Elab_Order
(New_Order, Title => "NEW ELABORATION ORDER");
pragma Assert (New_Pairs >= Old_Pairs);
end if;
end if;
end if;
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;
U := UNR.Table (U).Nextnp;
exit No_Pred_Search when U = No_Unit_Id;
end loop No_Pred_Search;
-- Now set the Elab_Positions in the Units table. It is important to
-- do this late, in case we're running both Elab_New and Elab_Old.
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,
-- but there are units left, hence we have a circular dependency,
-- which we will get Diagnose_Elaboration_Problem to diagnose it.
begin
for J in New_Order'Range loop
pragma Assert
(UNR.Table (New_Order (J)).Elab_Position = Positive (J));
Units_Array (New_Order (J)).Elab_Position := Positive (J);
end loop;
end;
if Best_So_Far = No_Unit_Id then
Diagnose_Elaboration_Problem;
if Errors_Detected = 0 then
-- 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
Choose (Best_So_Far);
Write_Elab_Order (New_Order, Title => "ELABORATION ORDER");
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;
----------------------
......@@ -1211,7 +1749,7 @@ package body Binde is
function Get_Line return String;
-- Read the next line from the file content read by Read_File. Strip
-- leading and trailing blanks. Convert "(spec)" or "(body)" to
-- all leading and trailing blanks. Convert "(spec)" or "(body)" to
-- "%s"/"%b". Remove comments (Ada style; "--" to end of line).
function Read_File (Name : String) return String_Ptr;
......@@ -1222,6 +1760,7 @@ package body Binde is
---------------
function Read_File (Name : String) return String_Ptr is
-- All of the following calls should succeed, because we checked the
-- file in Switch.B, but we double check and raise Program_Error on
-- failure, just in case.
......@@ -1363,6 +1902,7 @@ package body Binde is
while Cur <= S'Last loop
declare
Uname : constant Unit_Name_Type := Name_Find (Get_Line);
begin
if Uname = Empty_Name then
null; -- silently skip blank lines
......@@ -1370,25 +1910,32 @@ package body Binde is
elsif Get_Name_Table_Int (Uname) = 0
or else Unit_Id (Get_Name_Table_Int (Uname)) = No_Unit_Id
then
if Doing_New then
Write_Line
("""" & Get_Name_String (Uname) &
""": not present; ignored");
("""" & Get_Name_String (Uname)
& """: not present; ignored");
end if;
else
declare
Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname);
begin
if Is_Internal_File_Name (Units.Table (Cur_Unit).Sfile) then
if Doing_New then
Write_Line
("""" & Get_Name_String (Uname) &
""": predefined unit ignored");
end if;
else
if Prev_Unit /= No_Unit_Id then
if Doing_New then
Write_Unit_Name (Units.Table (Prev_Unit).Uname);
Write_Str (" <-- ");
Write_Unit_Name (Units.Table (Cur_Unit).Uname);
Write_Eol;
end if;
Build_Link
(Before => Prev_Unit,
......@@ -1419,9 +1966,9 @@ package body Binde is
for U in Units.First .. Units.Last loop
Cur_Unit := U;
-- If this is not an interface to a stand-alone library and
-- there is a body and a spec, then spec must be elaborated first
-- Note that the corresponding spec immediately follows the body
-- If this is not an interface to a stand-alone library and there is
-- a body and a spec, then spec must be elaborated first. Note that
-- the corresponding spec immediately follows the body.
if not Units.Table (U).SAL_Interface
and then Units.Table (U).Utype = Is_Body
......@@ -1429,12 +1976,13 @@ package body Binde is
Build_Link (Corresponding_Spec (U), U, Spec_First);
end if;
-- If this unit is not an interface to a stand-alone library,
-- process WITH references for this unit ignoring generic units and
-- interfaces to stand-alone libraries.
-- If this unit is not an interface to a stand-alone library, process
-- WITH references for this unit ignoring interfaces to stand-alone
-- libraries.
if not Units.Table (U).SAL_Interface then
for W in Units.Table (U).First_With .. Units.Table (U).Last_With
for W in Units.Table (U).First_With ..
Units.Table (U).Last_With
loop
if Withs.Table (W).Sfile /= No_File
and then (not Withs.Table (W).SAL_Interface)
......@@ -1446,9 +1994,12 @@ package body Binde is
-- obsolete unit with's a previous (now disappeared) spec.
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_Unit_1 := Withs.Table (W).Uname;
Error_Msg ("{ depends on $ which no longer exists");
end if;
goto Next_With;
end if;
......@@ -1457,7 +2008,10 @@ package body Binde is
-- Pragma Elaborate_All case, for this we use the recursive
-- Elab_All_Links procedure to establish the links.
if Withs.Table (W).Elaborate_All then
-- Elab_New ignores Elaborate_All and Elab_All_Desirable,
-- except for error messages.
if Withs.Table (W).Elaborate_All and then not Doing_New then
-- Reset flags used to stop multiple visits to a given
-- node.
......@@ -1476,8 +2030,9 @@ package body Binde is
-- Elaborate_All_Desirable case, for this we establish the
-- same links as above, but with a different reason.
elsif Withs.Table (W).Elab_All_Desirable then
elsif Withs.Table (W).Elab_All_Desirable
and then not Doing_New
then
-- Reset flags used to stop multiple visits to a given
-- node.
......@@ -1512,8 +2067,8 @@ package body Binde is
(Corresponding_Body (Withed_Unit), U, Elab);
end if;
-- Elaborate_Desirable case, for this we establish
-- the same links as above, but with a different reason.
-- Elaborate_Desirable case, for this we establish the same
-- links as above, but with a different reason.
elsif Withs.Table (W).Elab_Desirable then
Build_Link (Withed_Unit, U, Withed);
......@@ -1550,15 +2105,52 @@ package body Binde is
if Force_Elab_Order_File /= null then
Force_Elab_Order;
end if;
-- Output elaboration dependencies if option is set
if Elab_Dependency_Output or Debug_Flag_E then
if Doing_New then
Write_Dependencies;
end if;
end if;
end Gather_Dependencies;
----------
-- Init --
----------
procedure Init is
begin
Num_Chosen := 0;
Num_Left := Int (Units.Last - Units.First + 1);
Succ.Init;
Elab_All_Entries.Init;
UNR.Init;
-- Initialize unit table for elaboration control
for U in Units.First .. Units.Last loop
UNR.Append
((Successors => No_Successor,
Num_Pred => 0,
Nextnp => No_Unit_Id,
Visited => False,
Elab_Position => 0,
SCC_Root => No_Unit_Id,
Nodes => null,
SCC_Num_Pred => 0,
Validate_Seen => False));
end loop;
end Init;
------------------
-- Is_Body_Unit --
------------------
function Is_Body_Unit (U : Unit_Id) return Boolean is
begin
return Units.Table (U).Utype = Is_Body
return
Units.Table (U).Utype = Is_Body
or else Units.Table (U).Utype = Is_Body_Only;
end Is_Body_Unit;
......@@ -1571,16 +2163,14 @@ package body Binde is
-- If we have a body with separate spec, test flags on the spec
if Units.Table (U).Utype = Is_Body then
return Units.Table (Corresponding_Spec (U)).Preelab
or else
Units.Table (Corresponding_Spec (U)).Pure;
return
Units.Table (Corresponding_Spec (U)).Preelab
or else Units.Table (Corresponding_Spec (U)).Pure;
-- Otherwise we have a spec or body acting as spec, test flags on unit
else
return Units.Table (U).Preelab
or else
Units.Table (U).Pure;
return Units.Table (U).Preelab or else Units.Table (U).Pure;
end if;
end Is_Pure_Or_Preelab_Unit;
......@@ -1590,7 +2180,8 @@ package body Binde is
function Is_Waiting_Body (U : Unit_Id) return Boolean is
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;
end Is_Waiting_Body;
......@@ -1603,237 +2194,210 @@ package body Binde is
Link : Elab_All_Id) return Elab_All_Id
is
begin
Elab_All_Entries.Increment_Last;
Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam;
Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link;
Elab_All_Entries.Append ((Needed_By => Unam, Next_Elab => Link));
return Elab_All_Entries.Last;
end Make_Elab_All_Entry;
-------------------------------
-- Pessimistic_Better_Choice --
-------------------------------
----------------
-- Unit_Id_Of --
----------------
function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean is
UT1 : Unit_Record renames Units.Table (U1);
UT2 : Unit_Record renames Units.Table (U2);
function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
Info : constant Int := Get_Name_Table_Int (Uname);
begin
if Debug_Flag_B then
Write_Str ("Pessimistic_Better_Choice (");
Write_Unit_Name (UT1.Uname);
Write_Str (", ");
Write_Unit_Name (UT2.Uname);
Write_Line (")");
end if;
-- Note: the checks here are applied in sequence, and the ordering is
-- significant (i.e. the more important criteria are applied first).
pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
return Unit_Id (Info);
end Unit_Id_Of;
-- If either unit is predefined or internal, then we use the normal
-- Better_Choice rule, since we don't want to disturb the elaboration
-- rules of the language with -p, same treatment for Pure/Preelab.
--------------
-- Validate --
--------------
-- 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
if Debug_Flag_B then
Write_Line (" True: u1 is predefined, u2 is not");
begin
if Doing_New then
Msg := "New: ";
end if;
return True;
-- For each unit, assert that its successors are elaborated after it
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;
for J in Order'Range loop
declare
U : constant Unit_Id := Order (J);
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 Debug_Flag_B then
Write_Line (" True: u1 is internal, u2 is not");
end if;
if Doing_New then
for J in Order'Range loop
declare
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 Debug_Flag_B then
Write_Line (" False: u2 is internal, u1 is not");
if Units.Table (U).Utype = Is_Body then
if Order (J - 1) /= Corresponding_Spec (U) then
OK := False;
Write_Line (Msg & "Bad body with SCC of size 2:");
Write_SCC (SCC (U));
end if;
end if;
end if;
end;
end loop;
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)
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");
begin
if SCC (U) /= Cur_SCC then
Cur_SCC := SCC (U);
if UNR.Table (Cur_SCC).Validate_Seen then
OK := False;
Write_Line (Msg & "SCC not elaborated together:");
Write_SCC (Cur_SCC);
end if;
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");
UNR.Table (Cur_SCC).Validate_Seen := True;
end if;
end;
end loop;
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
if Debug_Flag_B then
Write_Line (" False: u1 is waiting body, u2 is not");
end if;
procedure Write_Closure (Order : Unit_Id_Array) is
package Closure_Sources is new Table.Table
(Table_Component_Type => File_Name_Type,
Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 10,
Table_Increment => 100,
Table_Name => "Gnatbind.Closure_Sources");
-- Table to record the sources in the closure, to avoid duplications
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
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;
--------------------
-- 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;
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 loop;
Closure_Sources.Append (S);
return True;
end Put_In_Sources;
-- If both are waiting bodies, then prefer the one whose spec is
-- less recently elaborated. Consider the following:
-- Local variables
-- spec of A
-- spec of B
-- body of A or B?
Source : File_Name_Type;
-- 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)
-- Start of processing for Write_Closure
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;
Closure_Sources.Init;
return Result;
end;
if not Zero_Formatting then
Write_Eol;
Write_Str ("REFERENCED SOURCES");
Write_Eol;
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
-- 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 Put_In_Sources (Source)
-- If we have two units, one of which is a spec for which this flag
-- is set, and the other is not, we normally prefer to delay the spec
-- for which the flag is set, so again Pessimistic_Better_Choice does
-- the opposite.
-- Do not include run-time units unless -Ra switch set
if not UT1.Elaborate_Body_Desirable
and then UT2.Elaborate_Body_Desirable
and then (List_Closure_All
or else not Is_Internal_File_Name (Source))
then
if Debug_Flag_B then
Write_Line (" False: u1 is elab body desirable, u2 is not");
if not Zero_Formatting then
Write_Str (" ");
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");
Write_Str (Get_Name_String (Source));
Write_Eol;
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
-- desirable, we normally prefer the one whose body is nearer to
-- being able to be elaborated, based on the Num_Pred count. This
-- helps to ensure bodies are as close to specs as possible. As
-- usual, Pessimistic_Better_Choice does the opposite.
for J in Sdep.First .. Sdep.Last loop
Source := Sdep.Table (J).Sfile;
elsif UT1.Elaborate_Body_Desirable
and then UT2.Elaborate_Body_Desirable
if Sdep.Table (J).Subunit_Name /= No_Name
and then Put_In_Sources (Source)
and then not Is_Internal_File_Name (Source)
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;
if not Zero_Formatting then
Write_Str (" ");
end if;
return Result;
end;
end if;
Write_Str (Get_Name_String (Source));
Write_Eol;
end if;
end loop;
-- If we fall through, it means that no preference rule applies, so we
-- use alphabetical order to at least give a deterministic result. Since
-- Pessimistic_Better_Choice is in the business of stirring up the
-- order, we will use reverse alphabetical ordering.
if Debug_Flag_B then
Write_Line (" choose on reverse alpha order");
if not Zero_Formatting then
Write_Eol;
end if;
return Uname_Less (UT2.Uname, UT1.Uname);
end Pessimistic_Better_Choice;
----------------
-- Unit_Id_Of --
----------------
function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
Info : constant Int := Get_Name_Table_Int (Uname);
begin
pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
return Unit_Id (Info);
end Unit_Id_Of;
end Write_Closure;
------------------------
-- Write_Dependencies --
......@@ -1892,8 +2456,8 @@ package body Binde is
else
Error_Msg_Output
(" which must be elaborated " &
"along with its spec:",
(" which must be elaborated along with its "
& "spec:",
Info => True);
end if;
......@@ -1920,4 +2484,695 @@ package body Binde is
end if;
end Write_Elab_All_Chain;
----------------------
-- Write_Elab_Order --
----------------------
procedure Write_Elab_Order
(Order : Unit_Id_Array; Title : String)
is
begin
if Title /= "" then
Write_Eol;
Write_Str (Title);
Write_Eol;
end if;
for J in Order'Range loop
if not Units.Table (Order (J)).SAL_Interface then
if not Zero_Formatting then
Write_Str (" ");
end if;
Write_Unit_Name (Units.Table (Order (J)).Uname);
Write_Eol;
end if;
end loop;
if Title /= "" then
Write_Eol;
end if;
end Write_Elab_Order;
--------------
-- Elab_New --
--------------
package body Elab_New is
generic
type Node is (<>);
First_Node : Node;
Last_Node : Node;
type Node_Array is array (Pos range <>) of Node;
with function Successors (N : Node) return Node_Array;
with procedure Create_SCC (Root : Node; Nodes : Node_Array);
procedure Compute_Strongly_Connected_Components;
-- Compute SCCs for a directed graph. The nodes in the graph are all
-- values of type Node in the range First_Node .. Last_Node.
-- Successors(N) returns the nodes pointed to by the edges emanating
-- from N. Create_SCC is a callback that is called once for each SCC,
-- passing in the Root node for that SCC (which is an arbitrary node in
-- the SCC used as a representative of that SCC), and the set of Nodes
-- in that SCC.
--
-- This is generic, in case we want to use it elsewhere; then we could
-- move this into a separate library unit. Unfortunately, it's not as
-- generic as one might like. Ideally, we would have "type Node is
-- private;", and pass in iterators to iterate over all nodes, and over
-- the successors of a given node. However, that leads to using advanced
-- features of Ada that are not allowed in the compiler and binder for
-- bootstrapping reason. It also leads to trampolines, which are not
-- allowed in the compiler and binder. Restricting Node to be discrete
-- allows us to iterate over all nodes with a 'for' loop, and allows us
-- to attach temporary information to nodes by having an array indexed
-- by Node.
procedure Compute_Unit_SCCs;
-- Use the above generic procedure to compute the SCCs for the graph of
-- units. Store in each Unit_Node_Record the SCC_Root and Nodes
-- components. Also initialize the SCC_Num_Pred components.
procedure Find_Elab_All_Errors;
-- Generate an error for illegal Elaborate_All pragmas (explicit or
-- implicit). A pragma Elaborate_All (Y) on unit X is legal if and only
-- if X and Y are in different SCCs.
-------------------------------------------
-- Compute_Strongly_Connected_Components --
-------------------------------------------
procedure Compute_Strongly_Connected_Components is
-- This uses Tarjan's algorithm for finding SCCs. Comments here are
-- intended to tell what it does, but if you want to know how it
-- works, you have to look it up. Please do not modify this code
-- without reading up on Tarjan's algorithm.
subtype Node_Index is Nat;
No_Index : constant Node_Index := 0;
Num_Nodes : constant Nat :=
Node'Pos (Last_Node) - Node'Pos (First_Node) + 1;
Stack : Node_Array (1 .. Num_Nodes);
Top : Node_Index := 0;
-- Stack of nodes, pushed when first visited. All nodes of an SCC are
-- popped at once when the SCC is found.
subtype Valid_Node is Node range First_Node .. Last_Node;
Node_Indices : array (Valid_Node) of Node_Index :=
(others => No_Index);
-- Each node has an "index", which is the sequential number in the
-- order in which they are visited in the recursive walk. No_Index
-- means "not yet visited"; we want to avoid walking any node more
-- than once.
Index : Node_Index := 1;
-- Next value to be assigned to a node index
Low_Links : array (Valid_Node) of Node_Index;
-- Low_Links (N) is the smallest index of nodes reachable from N
On_Stack : array (Valid_Node) of Boolean := (others => False);
-- True if the node is currently on the stack
procedure Walk (N : Valid_Node);
-- Recursive depth-first graph walk, with the node index used to
-- avoid visiting a node more than once.
----------
-- Walk --
----------
procedure Walk (N : Valid_Node) is
Stack_Position_Of_N : constant Pos := Top + 1;
S : constant Node_Array := Successors (N);
begin
-- Assign the index and low link, increment Index for next call to
-- Walk.
Node_Indices (N) := Index;
Low_Links (N) := Index;
Index := Index + 1;
-- Push it one the stack:
Top := Stack_Position_Of_N;
Stack (Top) := N;
On_Stack (N) := True;
-- Walk not-yet-visited subnodes, and update low link for visited
-- ones as appropriate.
for J in S'Range loop
if Node_Indices (S (J)) = No_Index then
Walk (S (J));
Low_Links (N) :=
Node_Index'Min (Low_Links (N), Low_Links (S (J)));
elsif On_Stack (S (J)) then
Low_Links (N) :=
Node_Index'Min (Low_Links (N), Node_Indices (S (J)));
end if;
end loop;
-- If the index is (still) equal to the low link, we've found an
-- SCC. Pop the whole SCC off the stack, and call Create_SCC.
if Low_Links (N) = Node_Indices (N) then
declare
SCC : Node_Array renames
Stack (Stack_Position_Of_N .. Top);
pragma Assert (SCC'Length >= 1);
pragma Assert (SCC (SCC'First) = N);
begin
for J in SCC'Range loop
On_Stack (SCC (J)) := False;
end loop;
Create_SCC (Root => N, Nodes => SCC);
pragma Assert (Top - SCC'Length = Stack_Position_Of_N - 1);
Top := Stack_Position_Of_N - 1; -- pop all
end;
end if;
end Walk;
-- Start of processing for Compute_Strongly_Connected_Components
begin
-- Walk all the nodes that have not yet been walked
for N in Valid_Node loop
if Node_Indices (N) = No_Index then
Walk (N);
end if;
end loop;
end Compute_Strongly_Connected_Components;
-----------------------
-- Compute_Unit_SCCs --
-----------------------
procedure Compute_Unit_SCCs is
function Successors (U : Unit_Id) return Unit_Id_Array;
-- Return all the units that must be elaborated after U. In addition,
-- if U is a body, include the corresponding spec; this ensures that
-- a spec/body pair are always in the same SCC.
procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array);
-- Set Nodes of the Root, and set SCC_Root of all the Nodes
procedure Init_SCC_Num_Pred (U : Unit_Id);
-- Initialize the SCC_Num_Pred fields, so that the root of each SCC
-- has a count of the number of successors of all the units in the
-- SCC, but only for successors outside the SCC.
procedure Compute_SCCs is new Compute_Strongly_Connected_Components
(Node => Unit_Id,
First_Node => Units.First,
Last_Node => Units.Last,
Node_Array => Unit_Id_Array,
Successors => Successors,
Create_SCC => Create_SCC);
----------------
-- Create_SCC --
----------------
procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array) is
begin
if Debug_Flag_V then
Write_Str ("Root = ");
Write_Int (Int (Root));
Write_Str (" ");
Write_Unit_Name (Units.Table (Root).Uname);
Write_Str (" -- ");
Write_Int (Nodes'Length);
Write_Str (" units:");
Write_Eol;
for J in Nodes'Range loop
Write_Str (" ");
Write_Int (Int (Nodes (J)));
Write_Str (" ");
Write_Unit_Name (Units.Table (Nodes (J)).Uname);
Write_Eol;
end loop;
end if;
pragma Assert (Nodes (Nodes'First) = Root);
pragma Assert (UNR.Table (Root).Nodes = null);
UNR.Table (Root).Nodes := new Unit_Id_Array'(Nodes);
for J in Nodes'Range loop
pragma Assert (SCC (Nodes (J)) = No_Unit_Id);
UNR.Table (Nodes (J)).SCC_Root := Root;
end loop;
end Create_SCC;
----------------
-- Successors --
----------------
function Successors (U : Unit_Id) return Unit_Id_Array is
S : Successor_Id := UNR.Table (U).Successors;
Tab : Unit_Id_Table;
begin
-- Pretend that a spec is a successor of its body (even though it
-- isn't), just so both get included.
if Units.Table (U).Utype = Is_Body then
Append (Tab, Corresponding_Spec (U));
end if;
-- Now include the real successors
while S /= No_Successor loop
pragma Assert (Succ.Table (S).Before = U);
Append (Tab, Succ.Table (S).After);
S := Succ.Table (S).Next;
end loop;
declare
Result : constant Unit_Id_Array := Tab.Table (1 .. Last (Tab));
begin
Free (Tab);
return Result;
end;
end Successors;
-----------------------
-- Init_SCC_Num_Pred --
-----------------------
procedure Init_SCC_Num_Pred (U : Unit_Id) is
begin
if UNR.Table (U).Visited then
return;
end if;
UNR.Table (U).Visited := True;
declare
S : Successor_Id := UNR.Table (U).Successors;
begin
while S /= No_Successor loop
pragma Assert (Succ.Table (S).Before = U);
Init_SCC_Num_Pred (Succ.Table (S).After);
if SCC (U) /= SCC (Succ.Table (S).After) then
UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred :=
UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred + 1;
end if;
S := Succ.Table (S).Next;
end loop;
end;
end Init_SCC_Num_Pred;
-- Start of processing for Compute_Unit_SCCs
begin
Compute_SCCs;
for Uref in UNR.First .. UNR.Last loop
pragma Assert (not UNR.Table (Uref).Visited);
null;
end loop;
for Uref in UNR.First .. UNR.Last loop
Init_SCC_Num_Pred (Uref);
end loop;
-- Assert that SCC_Root of all units has been set to a valid unit,
-- and that SCC_Num_Pred has not been modified in non-root units.
for Uref in UNR.First .. UNR.Last loop
pragma Assert (UNR.Table (Uref).SCC_Root /= No_Unit_Id);
pragma Assert (UNR.Table (Uref).SCC_Root in UNR.First .. UNR.Last);
if SCC (Uref) /= Uref then
pragma Assert (UNR.Table (Uref).SCC_Num_Pred = 0);
null;
end if;
end loop;
end Compute_Unit_SCCs;
--------------------------
-- Find_Elab_All_Errors --
--------------------------
procedure Find_Elab_All_Errors is
Withed_Unit : Unit_Id;
begin
for U in Units.First .. Units.Last loop
-- If this unit is not an interface to a stand-alone library,
-- process WITH references for this unit ignoring interfaces to
-- stand-alone libraries.
if not Units.Table (U).SAL_Interface then
for W in Units.Table (U).First_With ..
Units.Table (U).Last_With
loop
if Withs.Table (W).Sfile /= No_File
and then (not Withs.Table (W).SAL_Interface)
then
-- Check for special case of withing a unit that does not
-- exist any more.
if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then
goto Next_With;
end if;
Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname);
-- If it's Elaborate_All or Elab_All_Desirable, check
-- that the withER and withEE are not in the same SCC.
if Withs.Table (W).Elaborate_All
or else Withs.Table (W).Elab_All_Desirable
then
if SCC (U) = SCC (Withed_Unit) then
Illegal_Elab_All := True; -- ????
-- We could probably give better error messages
-- than Elab_Old here, but for now, to avoid
-- disruption, we don't give any error here.
-- Instead, we set the Illegal_Elab_All flag above,
-- and then run the Elab_Old algorithm to issue the
-- error message. Ideally, we would like to print
-- multiple errors rather than stopping after the
-- first cycle.
if False then
Error_Msg_Output
("illegal pragma Elaborate_All",
Info => False);
end if;
end if;
end if;
end if;
<<Next_With>>
null;
end loop;
end if;
end loop;
end Find_Elab_All_Errors;
---------------------
-- Find_Elab_Order --
---------------------
procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
Best_So_Far : Unit_Id;
U : Unit_Id;
begin
-- Gather dependencies and output them if option set
Gather_Dependencies;
Compute_Unit_SCCs;
-- Initialize the no predecessor list
No_Pred := No_Unit_Id;
for U in UNR.First .. UNR.Last loop
if UNR.Table (U).Num_Pred = 0 then
UNR.Table (U).Nextnp := No_Pred;
No_Pred := U;
end if;
end loop;
-- OK, now we determine the elaboration order proper. All we do is to
-- select the best choice from the no predecessor list until all the
-- nodes have been chosen.
Outer : loop
-- If there are no nodes with predecessors, then either we are
-- done, as indicated by Num_Left being set to zero, or we have
-- a circularity. In the latter case, diagnose the circularity,
-- removing it from the graph and continue.
-- ????But Diagnose_Elaboration_Problem always raises an
-- exception.
Get_No_Pred : while No_Pred = No_Unit_Id loop
exit Outer when Num_Left < 1;
Diagnose_Elaboration_Problem (Elab_Order);
end loop Get_No_Pred;
U := No_Pred;
Best_So_Far := No_Unit_Id;
-- Loop to choose best entry in No_Pred list
No_Pred_Search : loop
if Debug_Flag_N then
Write_Str (" considering choice of ");
Write_Unit_Name (Units.Table (U).Uname);
Write_Eol;
if Units.Table (U).Elaborate_Body then
Write_Str
(" Elaborate_Body = True, Num_Pred for body = ");
Write_Int
(UNR.Table (Corresponding_Body (U)).Num_Pred);
else
Write_Str
(" Elaborate_Body = False");
end if;
Write_Eol;
end if;
-- Don't even consider units whose SCC is not ready. This
-- ensures that all units of an SCC will be elaborated
-- together, with no other units in between.
if SCC_Num_Pred (U) = 0
and then Better_Choice (U, Best_So_Far)
then
if Debug_Flag_N then
Write_Str (" tentatively chosen (best so far)");
Write_Eol;
end if;
Best_So_Far := U;
end if;
U := UNR.Table (U).Nextnp;
exit No_Pred_Search when U = No_Unit_Id;
end loop No_Pred_Search;
-- Choose the best candidate found
Choose (Elab_Order, Best_So_Far);
-- If it's a spec with a body, and the body is not yet chosen,
-- choose the body if possible. The case where the body is
-- already chosen is Elaborate_Body; the above call to Choose
-- the spec will also Choose the body.
if Units.Table (Best_So_Far).Utype = Is_Spec
and then UNR.Table
(Corresponding_Body (Best_So_Far)).Elab_Position = 0
then
declare
Choose_The_Body : constant Boolean :=
UNR.Table (Corresponding_Body
(Best_So_Far)).Num_Pred = 0;
begin
if Debug_Flag_B then
Write_Str ("Can we choose the body?... ");
if Choose_The_Body then
Write_Line ("Yes!");
else
Write_Line ("No.");
end if;
end if;
if Choose_The_Body then
Choose (Elab_Order, Corresponding_Body (Best_So_Far));
end if;
end;
end if;
-- Finally, choose all the rest of the units in the same SCC as
-- Best_So_Far. If it hasn't been chosen (Elab_Position = 0), and
-- it's ready to be chosen (Num_Pred = 0), then we can choose it.
loop
declare
Chose_One_Or_More : Boolean := False;
SCC : Unit_Id_Array renames Nodes (Best_So_Far).all;
begin
for J in SCC'Range loop
if UNR.Table (SCC (J)).Elab_Position = 0
and then UNR.Table (SCC (J)).Num_Pred = 0
then
Chose_One_Or_More := True;
Choose (Elab_Order, SCC (J));
end if;
end loop;
exit when not Chose_One_Or_More;
end;
end loop;
end loop Outer;
Find_Elab_All_Errors;
end Find_Elab_Order;
-----------
-- Nodes --
-----------
function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr is
begin
return UNR.Table (SCC (U)).Nodes;
end Nodes;
---------
-- SCC --
---------
function SCC (U : Unit_Id) return Unit_Id is
begin
return UNR.Table (U).SCC_Root;
end SCC;
------------------
-- SCC_Num_Pred --
------------------
function SCC_Num_Pred (U : Unit_Id) return Int is
begin
return UNR.Table (SCC (U)).SCC_Num_Pred;
end SCC_Num_Pred;
---------------
-- Write_SCC --
---------------
procedure Write_SCC (U : Unit_Id) is
pragma Assert (SCC (U) = U);
begin
for J in Nodes (U)'Range loop
Write_Int (Int (UNR.Table (Nodes (U) (J)).Elab_Position));
Write_Str (". ");
Write_Unit_Name (Units.Table (Nodes (U) (J)).Uname);
Write_Eol;
end loop;
Write_Eol;
end Write_SCC;
end Elab_New;
--------------
-- Elab_Old --
--------------
package body Elab_Old is
---------------------
-- Find_Elab_Order --
---------------------
procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
Best_So_Far : Unit_Id;
U : Unit_Id;
begin
-- Gather dependencies and output them if option set
Gather_Dependencies;
-- Initialize the no predecessor list
No_Pred := No_Unit_Id;
for U in UNR.First .. UNR.Last loop
if UNR.Table (U).Num_Pred = 0 then
UNR.Table (U).Nextnp := No_Pred;
No_Pred := U;
end if;
end loop;
-- OK, now we determine the elaboration order proper. All we do is to
-- select the best choice from the no predecessor list until all the
-- nodes have been chosen.
Outer : loop
-- If there are no nodes with predecessors, then either we are
-- done, as indicated by Num_Left being set to zero, or we have
-- a circularity. In the latter case, diagnose the circularity,
-- removing it from the graph and continue.
-- ????But Diagnose_Elaboration_Problem always raises an
-- exception.
Get_No_Pred : while No_Pred = No_Unit_Id loop
exit Outer when Num_Left < 1;
Diagnose_Elaboration_Problem (Elab_Order);
end loop Get_No_Pred;
U := No_Pred;
Best_So_Far := No_Unit_Id;
-- Loop to choose best entry in No_Pred list
No_Pred_Search : loop
if Debug_Flag_N then
Write_Str (" considering choice of ");
Write_Unit_Name (Units.Table (U).Uname);
Write_Eol;
if Units.Table (U).Elaborate_Body then
Write_Str
(" Elaborate_Body = True, Num_Pred for body = ");
Write_Int
(UNR.Table (Corresponding_Body (U)).Num_Pred);
else
Write_Str
(" Elaborate_Body = False");
end if;
Write_Eol;
end if;
-- This is a candididate to be considered for choice
if Better_Choice (U, Best_So_Far) then
if Debug_Flag_N then
Write_Str (" tentatively chosen (best so far)");
Write_Eol;
end if;
Best_So_Far := U;
end if;
U := UNR.Table (U).Nextnp;
exit No_Pred_Search when U = No_Unit_Id;
end loop No_Pred_Search;
-- Choose the best candidate found
Choose (Elab_Order, Best_So_Far);
end loop Outer;
end Find_Elab_Order;
end Elab_Old;
end Binde;
gcc/ada/binde.ads
......@@ -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 Table;
with Namet; use Namet;
with Types; use Types;
package Binde is
with GNAT.Dynamic_Tables;
-- The following 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.
package Binde is
package Elab_Order is new Table.Table (
Table_Component_Type => Unit_Id,
package Unit_Id_Tables is new GNAT.Dynamic_Tables
(Table_Component_Type => Unit_Id,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 500,
Table_Increment => 200,
Table_Name => "Elab_Order");
Table_Increment => 200);
use Unit_Id_Tables;
procedure Find_Elab_Order;
-- Determine elaboration order
subtype Unit_Id_Table is Unit_Id_Tables.Instance;
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;
gcc/ada/bindgen.adb
......@@ -24,7 +24,6 @@
------------------------------------------------------------------------------
with ALI; use ALI;
with Binde; use Binde;
with Casing; use Casing;
with Fname; use Fname;
with Gnatvsn; use Gnatvsn;
......@@ -47,12 +46,13 @@ with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
with GNAT.HTable;
package body Bindgen is
use Binde.Unit_Id_Tables;
Statement_Buffer : String (1 .. 1000);
-- Buffer used for constructing output statements
Last : Natural := 0;
-- Last location in Statement_Buffer currently set
Stm_Last : Natural := 0;
-- Stm_Last location in Statement_Buffer currently set
With_GNARL : Boolean := False;
-- Flag which indicates whether the program uses the GNARL library
......@@ -113,8 +113,8 @@ package body Bindgen is
-- that the information is consistent across units. The entries
-- in this table are n/u/r/s for not set/user/runtime/system.
package IS_Pragma_Settings is new Table.Table (
Table_Component_Type => Character,
package IS_Pragma_Settings is new Table.Table
(Table_Component_Type => Character,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => 100,
......@@ -127,8 +127,8 @@ package body Bindgen is
-- The entries in this table are the upper case first character of the
-- policy name, e.g. 'F' for FIFO_Within_Priorities.
package PSD_Pragma_Settings is new Table.Table (
Table_Component_Type => Character,
package PSD_Pragma_Settings is new Table.Table
(Table_Component_Type => Character,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => 100,
......@@ -271,7 +271,7 @@ package body Bindgen is
-- Local Subprograms --
-----------------------
procedure Gen_Adainit;
procedure Gen_Adainit (Elab_Order : Unit_Id_Array);
-- Generates the Adainit procedure
procedure Gen_Adafinal;
......@@ -283,27 +283,29 @@ package body Bindgen is
procedure Gen_CodePeer_Wrapper;
-- For CodePeer, generate wrapper which calls user-defined main subprogram
procedure Gen_Elab_Calls;
procedure Gen_Elab_Calls (Elab_Order : Unit_Id_Array);
-- Generate sequence of elaboration calls
procedure Gen_Elab_Externals;
procedure Gen_Elab_Externals (Elab_Order : Unit_Id_Array);
-- Generate sequence of external declarations for elaboration
procedure Gen_Elab_Order;
procedure Gen_Elab_Order (Elab_Order : Unit_Id_Array);
-- Generate comments showing elaboration order chosen
procedure Gen_Finalize_Library;
procedure Gen_Finalize_Library (Elab_Order : Unit_Id_Array);
-- Generate a sequence of finalization calls to elaborated packages
procedure Gen_Main;
-- Generate procedure main
procedure Gen_Object_Files_Options;
procedure Gen_Object_Files_Options (Elab_Order : Unit_Id_Array);
-- Output comments containing a list of the full names of the object
-- files to be linked and the list of linker options supplied by
-- Linker_Options pragmas in the source.
procedure Gen_Output_File_Ada (Filename : String);
procedure Gen_Output_File_Ada
(Filename : String;
Elab_Order : Unit_Id_Array);
-- Generate Ada output file
procedure Gen_Restrictions;
......@@ -335,11 +337,11 @@ package body Bindgen is
-- the encoding method used for the main program source. If there is no
-- main program source (-z switch used), returns brackets ('b').
function Has_Finalizer return Boolean;
function Has_Finalizer (Elab_Order : Unit_Id_Array) return Boolean;
-- Determine whether the current unit has at least one library-level
-- finalizer.
function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;
function Lt_Linker_Option (Op1 : Natural; Op2 : Natural) return Boolean;
-- Compare linker options, when sorting, first according to
-- Is_Internal_File (internal files come later) and then by
-- elaboration order position (latest to earliest).
......@@ -347,21 +349,21 @@ package body Bindgen is
procedure Move_Linker_Option (From : Natural; To : Natural);
-- Move routine for sorting linker options
procedure Resolve_Binder_Options;
procedure Resolve_Binder_Options (Elab_Order : Unit_Id_Array);
-- Set the value of With_GNARL
procedure Set_Char (C : Character);
-- Set given character in Statement_Buffer at the Last + 1 position
-- and increment Last by one to reflect the stored character.
-- Set given character in Statement_Buffer at the Stm_Last + 1 position
-- and increment Stm_Last by one to reflect the stored character.
procedure Set_Int (N : Int);
-- Set given value in decimal in Statement_Buffer with no spaces starting
-- at the Last + 1 position, and updating Last past the value. A minus sign
-- is output for a negative value.
-- at the Stm_Last + 1 position, and updating Stm_Last past the value. A
-- minus sign is output for a negative value.
procedure Set_Boolean (B : Boolean);
-- Set given boolean value in Statement_Buffer at the Last + 1 position
-- and update Last past the value.
-- Set given boolean value in Statement_Buffer at the Stm_Last + 1 position
-- and update Stm_Last past the value.
procedure Set_IS_Pragma_Table;
-- Initializes contents of IS_Pragma_Settings table from ALI table
......@@ -369,7 +371,7 @@ package body Bindgen is
procedure Set_Main_Program_Name;
-- Given the main program name in Name_Buffer (length in Name_Len) generate
-- the name of the routine to be used in the call. The name is generated
-- starting at Last + 1, and Last is updated past it.
-- starting at Stm_Last + 1, and Stm_Last is updated past it.
procedure Set_Name_Buffer;
-- Set the value stored in positions 1 .. Name_Len of the Name_Buffer
......@@ -379,7 +381,7 @@ package body Bindgen is
procedure Set_String (S : String);
-- Sets characters of given string in Statement_Buffer, starting at the
-- Last + 1 position, and updating last past the string value.
-- Stm_Last + 1 position, and updating last past the string value.
procedure Set_String_Replace (S : String);
-- Replaces the last S'Length characters in the Statement_Buffer with the
......@@ -388,8 +390,8 @@ package body Bindgen is
procedure Set_Unit_Name;
-- Given a unit name in the Name_Buffer, copy it into Statement_Buffer,
-- starting at the Last + 1 position and update Last past the value.
-- Each dot (.) will be qualified into double underscores (__).
-- starting at the Stm_Last + 1 position and update Stm_Last past the
-- value. Each dot (.) will be qualified into double underscores (__).
procedure Set_Unit_Number (U : Unit_Id);
-- Sets unit number (first unit is 1, leading zeroes output to line up all
......@@ -397,11 +399,12 @@ package body Bindgen is
-- number of units.
procedure Write_Statement_Buffer;
-- Write out contents of statement buffer up to Last, and reset Last to 0
-- Write out contents of statement buffer up to Stm_Last, and reset
-- Stm_Last to 0.
procedure Write_Statement_Buffer (S : String);
-- First writes its argument (using Set_String (S)), then writes out the
-- contents of statement buffer up to Last, and reset Last to 0
-- contents of statement buffer up to Stm_Last, and reset Stm_Last to 0
procedure Write_Bind_Line (S : String);
-- Write S (an LF-terminated string) to the binder file (for use with
......@@ -472,7 +475,7 @@ package body Bindgen is
-- Gen_Adainit --
-----------------
procedure Gen_Adainit is
procedure Gen_Adainit (Elab_Order : Unit_Id_Array) is
Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU;
......@@ -892,8 +895,8 @@ package body Bindgen is
Write_Statement_Buffer;
end if;
-- Initialize stack limit variable of the environment task if the
-- stack check method is stack limit and stack check is enabled.
-- Initialize stack limit variable of the environment task if the stack
-- check method is stack limit and stack check is enabled.
if Stack_Check_Limits_On_Target
and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
......@@ -934,7 +937,7 @@ package body Bindgen is
WBI ("");
end if;
Gen_Elab_Calls;
Gen_Elab_Calls (Elab_Order);
if not CodePeer_Mode then
......@@ -980,9 +983,6 @@ package body Bindgen is
-------------------------
procedure Gen_Bind_Env_String is
KN, VN : Name_Id := No_Name;
Amp : Character;
procedure Write_Name_With_Len (Nam : Name_Id);
-- Write Nam as a string literal, prefixed with one
-- character encoding Nam's length.
......@@ -1002,10 +1002,17 @@ package body Bindgen is
Write_String_Table_Entry (End_String);
end Write_Name_With_Len;
-- Local variables
Amp : Character;
KN : Name_Id := No_Name;
VN : Name_Id := No_Name;
-- Start of processing for Gen_Bind_Env_String
begin
Bind_Environment.Get_First (KN, VN);
if VN = No_Name then
return;
end if;
......@@ -1058,15 +1065,15 @@ package body Bindgen is
-- Gen_Elab_Calls --
--------------------
procedure Gen_Elab_Calls is
procedure Gen_Elab_Calls (Elab_Order : Unit_Id_Array) is
Check_Elab_Flag : Boolean;
begin
-- Loop through elaboration order entries
for E in Elab_Order.First .. Elab_Order.Last loop
for E in Elab_Order'Range loop
declare
Unum : constant Unit_Id := Elab_Order.Table (E);
Unum : constant Unit_Id := Elab_Order (E);
U : Unit_Record renames Units.Table (Unum);
Unum_Spec : Unit_Id;
......@@ -1241,15 +1248,15 @@ package body Bindgen is
-- Gen_Elab_Externals --
------------------------
procedure Gen_Elab_Externals is
procedure Gen_Elab_Externals (Elab_Order : Unit_Id_Array) is
begin
if CodePeer_Mode then
return;
end if;
for E in Elab_Order.First .. Elab_Order.Last loop
for E in Elab_Order'Range loop
declare
Unum : constant Unit_Id := Elab_Order.Table (E);
Unum : constant Unit_Id := Elab_Order (E);
U : Unit_Record renames Units.Table (Unum);
begin
......@@ -1289,13 +1296,13 @@ package body Bindgen is
-- Gen_Elab_Order --
--------------------
procedure Gen_Elab_Order is
procedure Gen_Elab_Order (Elab_Order : Unit_Id_Array) is
begin
WBI (" -- BEGIN ELABORATION ORDER");
for J in Elab_Order.First .. Elab_Order.Last loop
for J in Elab_Order'Range loop
Set_String (" -- ");
Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
Get_Name_String (Units.Table (Elab_Order (J)).Uname);
Set_Name_Buffer;
Write_Statement_Buffer;
end loop;
......@@ -1308,12 +1315,7 @@ package body Bindgen is
-- Gen_Finalize_Library --
--------------------------
procedure Gen_Finalize_Library is
Count : Int := 1;
U : Unit_Record;
Uspec : Unit_Record;
Unum : Unit_Id;
procedure Gen_Finalize_Library (Elab_Order : Unit_Id_Array) is
procedure Gen_Header;
-- Generate the header of the finalization routine
......@@ -1327,6 +1329,13 @@ package body Bindgen is
WBI (" begin");
end Gen_Header;
-- Local variables
Count : Int := 1;
U : Unit_Record;
Uspec : Unit_Record;
Unum : Unit_Id;
-- Start of processing for Gen_Finalize_Library
begin
......@@ -1334,8 +1343,8 @@ package body Bindgen is
return;
end if;
for E in reverse Elab_Order.First .. Elab_Order.Last loop
Unum := Elab_Order.Table (E);
for E in reverse Elab_Order'Range loop
Unum := Elab_Order (E);
U := Units.Table (Unum);
-- Dealing with package bodies is a little complicated. In such
......@@ -1634,11 +1643,11 @@ package body Bindgen is
end if;
end if;
-- Generate a reference to Ada_Main_Program_Name. This symbol is
-- not referenced elsewhere in the generated program, but is needed
-- by the debugger (that's why it is generated in the first place).
-- The reference stops Ada_Main_Program_Name from being optimized
-- away by smart linkers, such as the AiX linker.
-- Generate a reference to Ada_Main_Program_Name. This symbol is not
-- referenced elsewhere in the generated program, but is needed by
-- the debugger (that's why it is generated in the first place). The
-- reference stops Ada_Main_Program_Name from being optimized away by
-- smart linkers, such as the AiX linker.
-- Because this variable is unused, we make this variable "aliased"
-- with a pragma Volatile in order to tell the compiler to preserve
......@@ -1664,9 +1673,9 @@ package body Bindgen is
WBI (" gnat_envp := envp;");
WBI ("");
-- If configurable run time and no command line args, then nothing
-- needs to be done since the gnat_argc/argv/envp variables are
-- suppressed in this case.
-- If configurable run time and no command line args, then nothing needs
-- to be done since the gnat_argc/argv/envp variables are suppressed in
-- this case.
elsif Configurable_Run_Time_On_Target then
null;
......@@ -1767,11 +1776,11 @@ package body Bindgen is
-- Gen_Object_Files_Options --
------------------------------
procedure Gen_Object_Files_Options is
procedure Gen_Object_Files_Options (Elab_Order : Unit_Id_Array) is
Lgnat : Natural;
-- This keeps track of the position in the sorted set of entries
-- in the Linker_Options table of where the first entry from an
-- internal file appears.
-- This keeps track of the position in the sorted set of entries in the
-- Linker_Options table of where the first entry from an internal file
-- appears.
Linker_Option_List_Started : Boolean := False;
-- Set to True when "LINKER OPTION LIST" is displayed
......@@ -1836,17 +1845,17 @@ package body Bindgen is
Set_List_File (Object_List_Filename.all);
end if;
for E in Elab_Order.First .. Elab_Order.Last loop
for E in Elab_Order'Range loop
-- If not spec that has an associated body, then generate a comment
-- giving the name of the corresponding object file.
if not Units.Table (Elab_Order.Table (E)).SAL_Interface
and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec
if not Units.Table (Elab_Order (E)).SAL_Interface
and then Units.Table (Elab_Order (E)).Utype /= Is_Spec
then
Get_Name_String
(ALIs.Table
(Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name);
(Units.Table (Elab_Order (E)).My_ALI).Ofile_Full_Name);
-- If the presence of an object file is necessary or if it exists,
-- then use it.
......@@ -1874,6 +1883,7 @@ package body Bindgen is
for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
declare
Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J);
begin
Name_Len := 0;
Add_Str_To_Name_Buffer ("-L");
......@@ -1996,7 +2006,10 @@ package body Bindgen is
-- Gen_Output_File --
---------------------
procedure Gen_Output_File (Filename : String) is
procedure Gen_Output_File
(Filename : String;
Elab_Order : Unit_Id_Array)
is
begin
-- Acquire settings for Interrupt_State pragmas
......@@ -2014,8 +2027,8 @@ package body Bindgen is
-- Count number of elaboration calls
for E in Elab_Order.First .. Elab_Order.Last loop
if Units.Table (Elab_Order.Table (E)).No_Elab then
for E in Elab_Order'Range loop
if Units.Table (Elab_Order (E)).No_Elab then
null;
else
Num_Elab_Calls := Num_Elab_Calls + 1;
......@@ -2024,21 +2037,23 @@ package body Bindgen is
-- Generate output file in appropriate language
Gen_Output_File_Ada (Filename);
Gen_Output_File_Ada (Filename, Elab_Order);
end Gen_Output_File;
-------------------------
-- Gen_Output_File_Ada --
-------------------------
procedure Gen_Output_File_Ada (Filename : String) is
procedure Gen_Output_File_Ada
(Filename : String; Elab_Order : Unit_Id_Array)
is
Ada_Main : constant String := Get_Ada_Main_Name;
-- Name to be used for generated Ada main program. See the body of
-- function Get_Ada_Main_Name for details on the form of the name.
Needs_Library_Finalization : constant Boolean :=
not Configurable_Run_Time_On_Target and then Has_Finalizer;
not Configurable_Run_Time_On_Target
and then Has_Finalizer (Elab_Order);
-- For restricted run-time libraries (ZFP and Ravenscar) tasks are
-- non-terminating, so we do not want finalization.
......@@ -2096,7 +2111,7 @@ package body Bindgen is
WBI ("with System.Secondary_Stack;");
end if;
Resolve_Binder_Options;
Resolve_Binder_Options (Elab_Order);
-- Generate standard with's
......@@ -2240,7 +2255,7 @@ package body Bindgen is
end if;
Gen_Versions;
Gen_Elab_Order;
Gen_Elab_Order (Elab_Order);
-- Spec is complete
......@@ -2323,7 +2338,7 @@ package body Bindgen is
-- Generate externals for elaboration entities
Gen_Elab_Externals;
Gen_Elab_Externals (Elab_Order);
if not CodePeer_Mode then
if not Suppress_Standard_Library_On_Target then
......@@ -2375,13 +2390,13 @@ package body Bindgen is
if not Cumulative_Restrictions.Set (No_Finalization) then
if Needs_Library_Finalization then
Gen_Finalize_Library;
Gen_Finalize_Library (Elab_Order);
end if;
Gen_Adafinal;
end if;
Gen_Adainit;
Gen_Adainit (Elab_Order);
if Bind_Main_Program then
Gen_Main;
......@@ -2389,7 +2404,7 @@ package body Bindgen is
-- Output object file list and the Ada body is complete
Gen_Object_Files_Options;
Gen_Object_Files_Options (Elab_Order);
WBI ("");
WBI ("end " & Ada_Main & ";");
......@@ -2519,8 +2534,8 @@ package body Bindgen is
WBI (" type Version_32 is mod 2 ** 32;");
for U in Units.First .. Units.Last loop
if not Units.Table (U).SAL_Interface
and then
(not Bind_For_Library or else Units.Table (U).Directly_Scanned)
and then (not Bind_For_Library
or else Units.Table (U).Directly_Scanned)
then
Increment_Ubuf;
WBI (" " & Ubuf & " : constant Version_32 := 16#" &
......@@ -2584,14 +2599,15 @@ package body Bindgen is
Nlen : Natural;
begin
-- For CodePeer, we want reproducible names (independent of other
-- mains that may or may not be present) that don't collide
-- when analyzing multiple mains and which are easily recognizable
-- as "ada_main" names.
-- For CodePeer, we want reproducible names (independent of other mains
-- that may or may not be present) that don't collide when analyzing
-- multiple mains and which are easily recognizable as "ada_main" names.
if CodePeer_Mode then
Get_Name_String (Units.Table (First_Unit_Entry).Uname);
return "ada_main_for_" &
return
"ada_main_for_" &
Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2));
end if;
......@@ -2713,13 +2729,13 @@ package body Bindgen is
-- Has_Finalizer --
-------------------
function Has_Finalizer return Boolean is
function Has_Finalizer (Elab_Order : Unit_Id_Array) return Boolean is
U : Unit_Record;
Unum : Unit_Id;
begin
for E in reverse Elab_Order.First .. Elab_Order.Last loop
Unum := Elab_Order.Table (E);
for E in reverse Elab_Order'Range loop
Unum := Elab_Order (E);
U := Units.Table (Unum);
-- We are only interested in non-generic packages
......@@ -2749,7 +2765,7 @@ package body Bindgen is
-- Lt_Linker_Option --
----------------------
function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is
function Lt_Linker_Option (Op1 : Natural; Op2 : Natural) return Boolean is
begin
-- Sort internal files last
......@@ -2771,7 +2787,6 @@ package body Bindgen is
return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
>
Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position;
end if;
end Lt_Linker_Option;
......@@ -2788,8 +2803,7 @@ package body Bindgen is
-- Resolve_Binder_Options --
----------------------------
procedure Resolve_Binder_Options is
procedure Resolve_Binder_Options (Elab_Order : Unit_Id_Array) is
procedure Check_Package (Var : in out Boolean; Name : String);
-- Set Var to true iff the current identifier in Namet is Name. Do
-- nothing if it doesn't match. This procedure is just a helper to
......@@ -2811,8 +2825,8 @@ package body Bindgen is
-- Start of processing for Resolve_Binder_Options
begin
for E in Elab_Order.First .. Elab_Order.Last loop
Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
for E in Elab_Order'Range loop
Get_Name_String (Units.Table (Elab_Order (E)).Uname);
-- This is not a perfect approach, but is the current protocol
-- between the run-time and the binder to indicate that tasking is
......@@ -2873,15 +2887,18 @@ package body Bindgen is
-----------------
procedure Set_Boolean (B : Boolean) is
True_Str : constant String := "True";
False_Str : constant String := "False";
True_Str : constant String := "True";
begin
if B then
Statement_Buffer (Last + 1 .. Last + True_Str'Length) := True_Str;
Last := Last + True_Str'Length;
Statement_Buffer (Stm_Last + 1 .. Stm_Last + True_Str'Length) :=
True_Str;
Stm_Last := Stm_Last + True_Str'Length;
else
Statement_Buffer (Last + 1 .. Last + False_Str'Length) := False_Str;
Last := Last + False_Str'Length;
Statement_Buffer (Stm_Last + 1 .. Stm_Last + False_Str'Length) :=
False_Str;
Stm_Last := Stm_Last + False_Str'Length;
end if;
end Set_Boolean;
......@@ -2891,8 +2908,8 @@ package body Bindgen is
procedure Set_Char (C : Character) is
begin
Last := Last + 1;
Statement_Buffer (Last) := C;
Stm_Last := Stm_Last + 1;
Statement_Buffer (Stm_Last) := C;
end Set_Char;
-------------
......@@ -2910,8 +2927,8 @@ package body Bindgen is
Set_Int (N / 10);
end if;
Last := Last + 1;
Statement_Buffer (Last) :=
Stm_Last := Stm_Last + 1;
Statement_Buffer (Stm_Last) :=
Character'Val (N mod 10 + Character'Pos ('0'));
end if;
end Set_Int;
......@@ -2951,8 +2968,8 @@ package body Bindgen is
begin
-- Note that name has %b on the end which we ignore
-- First we output the initial _ada_ since we know that the main
-- program is a library level subprogram.
-- First we output the initial _ada_ since we know that the main program
-- is a library level subprogram.
Set_String ("_ada_");
......@@ -3011,8 +3028,8 @@ package body Bindgen is
procedure Set_String (S : String) is
begin
Statement_Buffer (Last + 1 .. Last + S'Length) := S;
Last := Last + S'Length;
Statement_Buffer (Stm_Last + 1 .. Stm_Last + S'Length) := S;
Stm_Last := Stm_Last + S'Length;
end Set_String;
------------------------
......@@ -3021,7 +3038,7 @@ package body Bindgen is
procedure Set_String_Replace (S : String) is
begin
Statement_Buffer (Last - S'Length + 1 .. Last) := S;
Statement_Buffer (Stm_Last - S'Length + 1 .. Stm_Last) := S;
end Set_String_Replace;
-------------------
......@@ -3076,8 +3093,8 @@ package body Bindgen is
procedure Write_Statement_Buffer is
begin
WBI (Statement_Buffer (1 .. Last));
Last := 0;
WBI (Statement_Buffer (1 .. Stm_Last));
Stm_Last := 0;
end Write_Statement_Buffer;
procedure Write_Statement_Buffer (S : String) is
......
gcc/ada/bindgen.ads
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -32,9 +32,13 @@
-- See the body for exact details of the file that is generated
with Binde; use Binde;
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
procedure Set_Bind_Env (Key, Value : String);
......
gcc/ada/debug.adb
......@@ -181,14 +181,14 @@ package body Debug is
-- dl
-- dm
-- dn List details of manipulation of Num_Pred values
-- do Use old preference for elaboration order
-- dp
-- do Use older preference for elaboration order
-- dp Use new preference for elaboration order
-- dq
-- dr
-- ds
-- dt
-- du List units as they are acquired
-- dv
-- dv Verbose debugging printouts
-- dw
-- dx Force binder to read xref information from ali files
-- dy
......@@ -809,14 +809,25 @@ package body Debug is
-- the algorithm used to determine a correct order of elaboration. This
-- 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
-- specs with bodies, prefers the one whose body is closer to being
-- able to be elaborated. This is a clear improvement, but we provide
-- 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
-- dv Verbose debugging printouts
-- dx Force the binder to read (and then ignore) the xref information
-- in ali files (used to check that read circuit is working OK).
......
gcc/ada/einfo.ads
......@@ -670,14 +670,13 @@ package Einfo is
-- stored in a non-standard way, see body for details.
-- Component_Bit_Offset (Uint11)
-- Defined in record components (E_Component, E_Discriminant) if a
-- component clause applies to the component. First bit position of
-- given component, computed from the first bit and position values
-- given in the component clause. A value of No_Uint means that the
-- value is not yet known. The value can be set by the appearance of
-- an explicit component clause in a record representation clause,
-- or it can be set by the front-end in package Layout, or it can be
-- set by the backend. By the time backend processing is completed,
-- Defined in record components (E_Component, E_Discriminant). First
-- bit position of given component, computed from the first bit and
-- position values given in the component clause. A value of No_Uint
-- means that the value is not yet known. The value can be set by the
-- appearance of an explicit component clause in a record representation
-- clause, or it can be set by the front-end in package Layout, or it can
-- be set by the backend. By the time backend processing is completed,
-- 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
-- at run-time (this happens if fields of a record have variable
......
gcc/ada/g-locfil.ads
......@@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -39,7 +39,7 @@ package GNAT.Lock_Files is
-- Exception raised if file cannot be locked
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
-- separators are handled (i.e. slash and backslash).
......
gcc/ada/gnatbind.adb
......@@ -30,12 +30,10 @@ with Binde; use Binde;
with Binderr; use Binderr;
with Bindgen; use Bindgen;
with Bindusg;
with Butil; use Butil;
with Casing; use Casing;
with Csets;
with Debug; use Debug;
with Fmap;
with Fname; use Fname;
with Namet; use Namet;
with Opt; use Opt;
with Osint; use Osint;
......@@ -45,7 +43,6 @@ with Rident; use Rident;
with Snames;
with Switch; use Switch;
with Switch.B; use Switch.B;
with Table;
with Targparm; use Targparm;
with Types; use Types;
......@@ -76,22 +73,15 @@ procedure Gnatbind is
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);
-- Artificially add ALI file Name in the closure
function Gnatbind_Supports_Auto_Init return Boolean;
-- Indicates if automatic initialization of elaboration procedure
-- through the constructor mechanism is possible on the platform.
-- Indicates if automatic initialization of elaboration procedure through
-- 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;
-- List restrictions that apply to this partition if option taken
......@@ -110,9 +100,6 @@ procedure Gnatbind is
procedure Write_Arg (S : String);
-- 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 --
-----------------------------
......@@ -149,6 +136,7 @@ procedure Gnatbind is
function gnat_binder_supports_auto_init return Integer;
pragma Import (C, gnat_binder_supports_auto_init,
"__gnat_binder_supports_auto_init");
begin
return gnat_binder_supports_auto_init /= 0;
end Gnatbind_Supports_Auto_Init;
......@@ -160,6 +148,7 @@ procedure Gnatbind is
function Is_Cross_Compiler return Boolean is
Cross_Compiler : Integer;
pragma Import (C, Cross_Compiler, "__gnat_is_cross_compiler");
begin
return Cross_Compiler = 1;
end Is_Cross_Compiler;
......@@ -292,8 +281,8 @@ procedure Gnatbind is
if not Additional_Restrictions_Listed then
Write_Eol;
Write_Line
("The following additional restrictions may be" &
" applied to this partition:");
("The following additional restrictions may be applied to "
& "this partition:");
Additional_Restrictions_Listed := True;
end if;
......@@ -301,6 +290,7 @@ procedure Gnatbind is
declare
S : constant String := Restriction_Id'Image (R);
begin
Name_Len := S'Length;
Name_Buffer (1 .. Name_Len) := S;
......@@ -377,8 +367,8 @@ procedure Gnatbind is
else
Fail
("Prefix of initialization and finalization " &
"procedure names missing in -L");
("Prefix of initialization and finalization procedure names "
& "missing in -L");
end if;
-- -Sin -Slo -Shi -Sxx -Sev
......@@ -560,12 +550,12 @@ procedure Gnatbind is
Write_Str (" " & S);
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
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
begin
......@@ -618,8 +608,8 @@ begin
Fail ("switch -a must be used in conjunction with -n or -Lxxx");
elsif not Gnatbind_Supports_Auto_Init then
Fail ("automatic initialisation of elaboration " &
"not supported on this platform");
Fail ("automatic initialisation of elaboration not supported on this "
& "platform");
end if;
end if;
......@@ -641,6 +631,7 @@ begin
Check_Extensions : declare
Length : constant Natural := Output_File_Name'Length;
Last : constant Natural := Output_File_Name'Last;
begin
if Length <= 4
or else Output_File_Name (Last - 3 .. Last) /= ".adb"
......@@ -873,132 +864,19 @@ begin
-- Complete bind if no errors
if Errors_Detected = 0 then
Find_Elab_Order;
if Errors_Detected = 0 then
-- 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
declare
Elab_Order : Unit_Id_Table;
use Unit_Id_Tables;
begin
Closure_Sources.Init;
Find_Elab_Order (Elab_Order, First_Main_Lib_File);
if not Zero_Formatting then
Write_Eol;
Write_Str ("REFERENCED SOURCES");
Write_Eol;
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;
if Errors_Detected = 0 and then not Check_Only then
Gen_Output_File
(Output_File_Name.all,
Elab_Order => Elab_Order.Table (First .. Last (Elab_Order)));
end if;
end;
end if;
Total_Errors := Total_Errors + Errors_Detected;
......@@ -1010,7 +888,7 @@ begin
Total_Warnings := Total_Warnings + Warnings_Detected;
end;
-- All done. Set proper exit status
-- All done. Set the proper exit status.
Finalize_Binderr;
Namet.Finalize;
......
gcc/ada/sem_ch13.adb
......@@ -10374,15 +10374,26 @@ package body Sem_Ch13 is
Nbit := Sbit;
for J in 1 .. Ncomps loop
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
Error_Msg_NE
("?H?^-bit gap before component&",
Component_Name (Component_Clause (CEnt)), CEnt);
Component_Name (Component_Clause (CEnt)),
CEnt);
end if;
Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt);
Nbit := CBO + Esize (CEnt);
end if;
end;
end loop;
-- Process variant parts recursively if present
......
gcc/ada/sem_ch6.adb
......@@ -274,6 +274,7 @@ package body Sem_Ch6 is
New_Spec : Node_Id;
Orig_N : Node_Id;
Ret : Node_Id;
Ret_Type : Entity_Id;
Prev : Entity_Id;
-- If the expression is a completion, Prev is the entity whose
......@@ -366,16 +367,34 @@ package body Sem_Ch6 is
then
Set_Has_Completion (Prev, False);
Set_Is_Inlined (Prev);
Ret_Type := Etype (Prev);
-- An expression function that is a completion freezes the
-- expression. This means freezing the return type, and if it is
-- an access type, freezing its designated type as well.
-- expression. This means freezing the return type, and if it is an
-- access type, freezing its designated type as well.
-- Note that we cannot defer this freezing to the analysis of the
-- expression itself, because a freeze node might appear in a nested
-- 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
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