diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 42 | ||||
| -rw-r--r-- | gcc/ada/ali.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/ali.ads | 7 | ||||
| -rw-r--r-- | gcc/ada/binde.adb | 2145 | ||||
| -rw-r--r-- | gcc/ada/binde.ads | 40 | ||||
| -rw-r--r-- | gcc/ada/bindgen.adb | 273 | ||||
| -rw-r--r-- | gcc/ada/bindgen.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/debug.adb | 19 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/g-locfil.ads | 4 | ||||
| -rw-r--r-- | gcc/ada/gnatbind.adb | 186 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 25 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 25 |
13 files changed, 2014 insertions, 784 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5d5be94..fba33935 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,47 @@ 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 diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb index d60d498..d42cb34 100644 --- a/gcc/ada/ali.adb +++ b/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 diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index eea6b46..c51129d 100644 --- a/gcc/ada/ali.ads +++ b/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 diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb index ffb3b91..ea34127 100644 --- a/gcc/ada/binde.adb +++ b/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,17 +180,17 @@ package body Binde is Succ_First : constant := 1; - package Succ is new Table.Table ( - Table_Component_Type => Successor_Link, - Table_Index_Type => Successor_Id, - Table_Low_Bound => Succ_First, - Table_Initial => 500, - Table_Increment => 200, - Table_Name => "Succ"); + package Succ is new Table.Table + (Table_Component_Type => Successor_Link, + Table_Index_Type => Successor_Id, + Table_Low_Bound => Succ_First, + Table_Initial => 500, + Table_Increment => 200, + Table_Name => "Succ"); -- For the case of Elaborate_All, the following table is used to record - -- chains of with relationships that lead to the Elab_All link. These - -- are used solely for diagnostic purposes + -- chains of with relationships that lead to the Elab_All link. These are + -- used solely for diagnostic purposes type Elab_All_Entry is record Needed_By : Unit_Name_Type; @@ -153,50 +201,74 @@ 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, - Table_Index_Type => Elab_All_Id, - Table_Low_Bound => 1, - Table_Initial => 2000, - Table_Increment => 200, - Table_Name => "Elab_All_Entries"); + package Elab_All_Entries is new Table.Table + (Table_Component_Type => Elab_All_Entry, + Table_Index_Type => Elab_All_Id, + Table_Low_Bound => 1, + Table_Initial => 2000, + Table_Increment => 200, + Table_Name => "Elab_All_Entries"); - -- A Unit_Node record is built for each active unit + type Unit_Id_Array_Ptr is access Unit_Id_Array; - type Unit_Node_Record is record + -- A Unit_Node_Record is built for each active unit + type Unit_Node_Record is record Successors : Successor_Id; -- Pointer to list of links for successor nodes Num_Pred : Int; - -- Number of predecessors for this unit. Normally non-negative, but - -- can go negative in the case of units chosen by the diagnose error - -- procedure (when cycles are being removed from the graph). + -- Number of predecessors for this unit that have not yet been chosen. + -- Normally non-negative, but can go negative in the case of units + -- chosen by the diagnose error procedure (when cycles are being removed + -- from the graph). Nextnp : Unit_Id; -- Forward pointer for list of units with no predecessors - Elab_Order : Nat; - -- Position in elaboration order (zero = not placed yet) - Visited : Boolean; - -- Used in computing transitive closure for Elaborate_All and - -- also in locating cycles and paths in the diagnose routines. + -- Used in computing transitive closure for Elaborate_All and also in + -- locating cycles and paths in the diagnose routines. Elab_Position : Natural; - -- Initialized to zero. Set non-zero when a unit is chosen and - -- placed in the elaboration order. The value represents the - -- ordinal position in the elaboration order. - + -- Initialized to zero. Set non-zero when a unit is chosen and placed in + -- the elaboration order. The value represents the ordinal position in + -- the elaboration order. + + -- The following are for Elab_New. We compute the strongly connected + -- components (SCCs) of the directed graph of units. The edges are the + -- Successors, which do not include pragmas Elaborate_All (explicit or + -- implicit) in Elab_New. In addition, we assume there is a edge + -- pointing from a body to its corresponding spec; this edge is not + -- included in Successors, because of course a spec is elaborated BEFORE + -- its body, not after. + + SCC_Root : Unit_Id; + -- Each unit points to the root of its SCC, which is just an arbitrary + -- member of the SCC. Two units are in the same SCC if and only if their + -- SCC_Roots are equal. U is the root of its SCC if and only if + -- SCC(U)=U. + + Nodes : Unit_Id_Array_Ptr; + -- Present only in the root of an SCC. This is the set of units in the + -- SCC, in no particular order. + + SCC_Num_Pred : Int; + -- Present only in the root of an SCC. This is the number of predecessor + -- units of the SCC that are in other SCCs, and that have not yet been + -- chosen. + + Validate_Seen : Boolean := False; + -- See procedure Validate below end record; - package UNR is new Table.Table ( - Table_Component_Type => Unit_Node_Record, - Table_Index_Type => Unit_Id, - Table_Low_Bound => First_Unit_Entry, - Table_Initial => 500, - Table_Increment => 200, - Table_Name => "UNR"); + package UNR is new Table.Table + (Table_Component_Type => Unit_Node_Record, + Table_Index_Type => Unit_Id, + Table_Low_Bound => First_Unit_Entry, + Table_Initial => 500, + Table_Increment => 200, + Table_Name => "UNR"); No_Pred : Unit_Id; -- Head of list of items with no predecessors @@ -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,23 +577,23 @@ 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 Result : constant Boolean := - UNR.Table (Corresponding_Spec (U1)).Elab_Position > - UNR.Table (Corresponding_Spec (U2)).Elab_Position; + UNR.Table (Corresponding_Spec (U1)).Elab_Position > + UNR.Table (Corresponding_Spec (U2)).Elab_Position; begin if Debug_Flag_B then if Result then @@ -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 @@ -490,8 +648,8 @@ package body Binde is then declare Result : constant Boolean := - UNR.Table (Corresponding_Body (U1)).Num_Pred < - UNR.Table (Corresponding_Body (U2)).Num_Pred; + UNR.Table (Corresponding_Body (U1)).Num_Pred < + UNR.Table (Corresponding_Body (U2)).Num_Pred; begin if Debug_Flag_B then if Result then @@ -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 -- @@ -559,16 +971,17 @@ package body Binde is -- Fall through on normal case - Succ.Table (Succ.Last).After := After; - Succ.Table (Succ.Last).Elab_Body := False; - UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1; + Succ.Table (Succ.Last).After := After; + Succ.Table (Succ.Last).Elab_Body := False; + UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1; end Build_Link; ------------ -- Choose -- ------------ - procedure Choose (Chosen : Unit_Id) is + procedure Choose (Elab_Order : in out Unit_Id_Table; Chosen : Unit_Id) is + pragma Assert (Chosen /= No_Unit_Id); S : Successor_Id; U : Unit_Id; @@ -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; + if Doing_New and then SCC (U) /= SCC (Chosen) then + UNR.Table (SCC (U)).SCC_Num_Pred := + UNR.Table (SCC (U)).SCC_Num_Pred - 1; + + if Debug_Flag_N then + Write_Str (" decrementing SCC_Num_Pred for unit "); + Write_Unit_Name (Units.Table (U).Uname); + Write_Str (" new value = "); + Write_Int (SCC_Num_Pred (U)); + Write_Eol; + end if; + end if; + S := Succ.Table (S).Next; end loop; -- All done, adjust number of units left count and set elaboration pos - Num_Left := Num_Left - 1; + Num_Left := Num_Left - 1; Num_Chosen := Num_Chosen + 1; + + 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 @@ -918,11 +1387,12 @@ package body Binde is if Info = 0 or else Unit_Id (Info) = No_Unit_Id then declare - Withed : String := - Get_Name_String (Withs.Table (W).Uname); + Withed : String := + Get_Name_String (Withs.Table (W).Uname); Last_Withed : Natural := Withed'Last; - Withing : String := - Get_Name_String (Units.Table (Before).Uname); + Withing : String := + Get_Name_String + (Units.Table (Before).Uname); Last_Withing : Natural := Withing'Last; Spec_Body : String := " (Spec)"; @@ -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)); - end loop; + 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 - - Gather_Dependencies; - - -- Output elaboration dependencies if option is set + if Do_New then + if Debug_Flag_V then + Write_Line ("Doing new..."); + end if; - if Elab_Dependency_Output or Debug_Flag_E then - Write_Dependencies; + Doing_New := True; + Init; + Elab_New.Find_Elab_Order (Elab_Order); end if; - -- Initialize the no predecessor list + -- Elab_New does not support the pessimistic order, so if that was + -- requested, use the old results. Use Elab_Old if -dp was selected. + -- Elab_New does not yet give proper error messages for illegal + -- Elaborate_Alls, so if there is one, run Elab_Old. - No_Pred := No_Unit_Id; - for U in UNR.First .. UNR.Last loop - if UNR.Table (U).Num_Pred = 0 then - UNR.Table (U).Nextnp := No_Pred; - No_Pred := U; + if Do_Old + or Pessimistic_Elab_Order + or Debug_Flag_Old + or Illegal_Elab_All + then + if Debug_Flag_V then + Write_Line ("Doing old..."); end if; - end loop; - -- OK, now we determine the elaboration order proper. All we do is to - -- select the best choice from the no predecessor list until all the - -- nodes have been chosen. + Doing_New := False; + Init; + Elab_Old.Find_Elab_Order (Old_Elab_Order); + end if; - Outer : loop + 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); - -- 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 + begin + if Do_Old and Do_New then + Write_Line (Get_Name_String (First_Main_Lib_File)); - Get_No_Pred : while No_Pred = No_Unit_Id loop - exit Outer when Num_Left < 1; - Diagnose_Elaboration_Problem; - end loop Get_No_Pred; + pragma Assert (Old_Order'Length = New_Order'Length); + pragma Debug (Validate (Old_Order, Doing_New => False)); + pragma Debug (Validate (New_Order, Doing_New => True)); - U := No_Pred; - Best_So_Far := No_Unit_Id; + -- Misc debug printouts that can be used for experimentation by + -- changing the 'if's below. - -- Loop to choose best entry in No_Pred list + 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; - No_Pred_Search : loop - if Debug_Flag_N then - Write_Str (" considering choice of "); - Write_Unit_Name (Units.Table (U).Uname); - Write_Eol; + 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; + + if True then + Write_Str ("Pairs: "); + Write_Int (Old_Pairs); - if Units.Table (U).Elaborate_Body then - Write_Str - (" Elaborate_Body = True, Num_Pred for body = "); - Write_Int - (UNR.Table (Corresponding_Body (U)).Num_Pred); + if Old_Pairs = New_Pairs then + Write_Str (" = "); + elsif Old_Pairs < New_Pairs then + Write_Str (" < "); else - Write_Str - (" Elaborate_Body = False"); + Write_Str (" > "); end if; + Write_Int (New_Pairs); Write_Eol; end if; - -- This is a candididate to be considered for choice + if Old_Pairs /= New_Pairs and then False then + Write_Str ("Pairs: "); + Write_Int (Old_Pairs); - if Best_So_Far = No_Unit_Id - or else ((not Pessimistic_Elab_Order) - and then Better_Choice (U, Best_So_Far)) - or else (Pessimistic_Elab_Order - and then Pessimistic_Better_Choice (U, Best_So_Far)) - then - if Debug_Flag_N then - Write_Str (" tentatively chosen (best so far)"); - Write_Eol; + if Old_Pairs < New_Pairs then + Write_Str (" < "); + else + Write_Str (" > "); end if; - Best_So_Far := U; + Write_Int (New_Pairs); + Write_Eol; + + if Old_Pairs /= New_Pairs and then Debug_Flag_V then + Write_Elab_Order + (Old_Order, Title => "OLD ELABORATION ORDER"); + Write_Elab_Order + (New_Order, Title => "NEW ELABORATION ORDER"); + pragma Assert (New_Pairs >= Old_Pairs); + end if; end if; + end if; - U := UNR.Table (U).Nextnp; - exit No_Pred_Search when U = No_Unit_Id; - end loop No_Pred_Search; + -- The Elab_New algorithm doesn't implement the -p switch, so if that + -- was used, use the results from the old algorithm. + + if Pessimistic_Elab_Order or Debug_Flag_Old then + New_Order := Old_Order; + end if; - -- 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. + -- 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. - if Best_So_Far = No_Unit_Id then - Diagnose_Elaboration_Problem; + declare + Units_Array : Units.Table_Type renames + Units.Table (Units.First .. Units.Last); - -- Otherwise choose the best candidate found + 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; - else - Choose (Best_So_Far); + if Errors_Detected = 0 then + + -- Display elaboration order if -l was specified + + if Elab_Order_Output then + if Zero_Formatting then + Write_Elab_Order (New_Order, Title => ""); + else + Write_Elab_Order (New_Order, Title => "ELABORATION ORDER"); + end if; + end if; + + -- Display list of sources in the closure (except predefined + -- sources) if -R was used. Include predefined sources if -Ra + -- was used. + + if List_Closure then + Write_Closure (New_Order); + end if; end if; - end loop Outer; + end; end Find_Elab_Order; ---------------------- @@ -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 - Write_Line - ("""" & Get_Name_String (Uname) & - """: not present; ignored"); + if Doing_New then + Write_Line + ("""" & Get_Name_String (Uname) + & """: not present; ignored"); + end if; else declare Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname); + begin if Is_Internal_File_Name (Units.Table (Cur_Unit).Sfile) then - Write_Line - ("""" & Get_Name_String (Uname) & - """: predefined unit ignored"); + if Doing_New then + Write_Line + ("""" & Get_Name_String (Uname) & + """: predefined unit ignored"); + end if; else if Prev_Unit /= No_Unit_Id then - Write_Unit_Name (Units.Table (Prev_Unit).Uname); - Write_Str (" <-- "); - Write_Unit_Name (Units.Table (Cur_Unit).Uname); - Write_Eol; + if Doing_New then + Write_Unit_Name (Units.Table (Prev_Unit).Uname); + Write_Str (" <-- "); + Write_Unit_Name (Units.Table (Cur_Unit).Uname); + Write_Eol; + end if; Build_Link (Before => Prev_Unit, @@ -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 - Error_Msg_File_1 := Units.Table (U).Sfile; - Error_Msg_Unit_1 := Withs.Table (W).Uname; - Error_Msg ("{ depends on $ which no longer exists"); + if Doing_New then + Error_Msg_File_1 := Units.Table (U).Sfile; + Error_Msg_Unit_1 := Withs.Table (W).Uname; + Error_Msg ("{ depends on $ which no longer exists"); + end if; + goto Next_With; end if; @@ -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,16 +2105,53 @@ 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 - or else Units.Table (U).Utype = Is_Body_Only; + return + Units.Table (U).Utype = Is_Body + or else Units.Table (U).Utype = Is_Body_Only; end Is_Body_Unit; ----------------------------- @@ -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,8 +2180,9 @@ package body Binde is function Is_Waiting_Body (U : Unit_Id) return Boolean is begin - return Units.Table (U).Utype = Is_Body - and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0; + return + Units.Table (U).Utype = Is_Body + and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0; end Is_Waiting_Body; ------------------------- @@ -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). - - -- 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. - - -- 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; + pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); + return Unit_Id (Info); + end Unit_Id_Of; - return True; + -------------- + -- Validate -- + -------------- - 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; + procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean) is + Cur_SCC : Unit_Id := No_Unit_Id; + OK : Boolean := True; + Msg : String := "Old: "; - return False; + begin + if Doing_New then + Msg := "New: "; + end if; - -- Prefer a pure or preelaborable unit to one that is not + -- For each unit, assert that its successors are elaborated after it - 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; + for J in Order'Range loop + declare + U : constant Unit_Id := Order (J); + S : Successor_Id := UNR.Table (U).Successors; - return True; + 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; - 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; + -- An SCC of size 2 units necessarily consists of a spec and the + -- corresponding body. Assert that the body is elaborated immediately + -- after the spec, with nothing in between. (We only have SCCs in the + -- new algorithm.) - return False; + if Doing_New then + for J in Order'Range loop + declare + U : constant Unit_Id := Order (J); - -- Prefer anything else to a waiting body. We want to make bodies wait - -- as long as possible, till we are forced to choose them. + 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 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; + 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. - elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then - if Debug_Flag_B then - Write_Line (" True: u2 is waiting body, u1 is not"); - end if; + for J in Order'Range loop + declare + U : constant Unit_Id := Order (J); - return True; + begin + if SCC (U) /= Cur_SCC then + Cur_SCC := SCC (U); + if UNR.Table (Cur_SCC).Validate_Seen then + OK := False; + Write_Line (Msg & "SCC not elaborated together:"); + Write_SCC (Cur_SCC); + end if; - -- Prefer a spec to a body (this is mandatory) + UNR.Table (Cur_SCC).Validate_Seen := True; + end if; + end; + end loop; + end if; - 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; + pragma Assert (OK); + end Validate; - return False; + ------------------- + -- Write_Closure -- + ------------------- - 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; + procedure Write_Closure (Order : Unit_Id_Array) is + package Closure_Sources is new Table.Table + (Table_Component_Type => File_Name_Type, + Table_Index_Type => Natural, + Table_Low_Bound => 1, + Table_Initial => 10, + Table_Increment => 100, + Table_Name => "Gnatbind.Closure_Sources"); + -- Table to record the sources in the closure, to avoid duplications + + function Put_In_Sources (S : File_Name_Type) return Boolean; + -- Check if S is already in table Sources and put in Sources if it is + -- not. Return False if the source is already in Sources, and True if + -- it is added. + + -------------------- + -- Put_In_Sources -- + -------------------- + + function Put_In_Sources (S : File_Name_Type) return Boolean is + begin + for J in 1 .. Closure_Sources.Last loop + if Closure_Sources.Table (J) = S then + return False; + end if; + end loop; + Closure_Sources.Append (S); return True; + end Put_In_Sources; - -- 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; + begin + 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"); - end if; + 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; - end if; + if not Zero_Formatting then + Write_Str (" "); + end if; - return Result; - end; + Write_Str (Get_Name_String (Source)); + Write_Eol; end if; - end if; - - -- If we fall through, it means that no preference rule applies, so we - -- use alphabetical order to at least give a deterministic result. Since - -- Pessimistic_Better_Choice is in the business of stirring up the - -- order, we will use reverse alphabetical ordering. + end loop; - if Debug_Flag_B then - Write_Line (" choose on reverse alpha order"); + if not Zero_Formatting then + Write_Eol; end if; - - return Uname_Less (UT2.Uname, UT1.Uname); - end Pessimistic_Better_Choice; - - ---------------- - -- Unit_Id_Of -- - ---------------- - - function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is - Info : constant Int := Get_Name_Table_Int (Uname); - begin - pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id); - return Unit_Id (Info); - end Unit_Id_Of; + end Write_Closure; ------------------------ -- Write_Dependencies -- @@ -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; diff --git a/gcc/ada/binde.ads b/gcc/ada/binde.ads index 4481ef2..79d9cdf 100644 --- a/gcc/ada/binde.ads +++ b/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; +with GNAT.Dynamic_Tables; + package Binde is - -- 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 + 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); + use Unit_Id_Tables; + + 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. - package Elab_Order is new Table.Table ( - Table_Component_Type => Unit_Id, - Table_Index_Type => Nat, - Table_Low_Bound => 1, - Table_Initial => 500, - Table_Increment => 200, - Table_Name => "Elab_Order"); - - procedure Find_Elab_Order; - -- Determine elaboration order - end Binde; diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb index 0955b1a..d6c9a83 100644 --- a/gcc/ada/bindgen.adb +++ b/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,13 +113,13 @@ 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, - Table_Index_Type => Int, - Table_Low_Bound => 0, - Table_Initial => 100, - Table_Increment => 200, - Table_Name => "IS_Pragma_Settings"); + package IS_Pragma_Settings is new Table.Table + (Table_Component_Type => Character, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "IS_Pragma_Settings"); -- This table assembles the Priority_Specific_Dispatching pragma -- information from all the units in the partition. Note that Bcheck has @@ -127,13 +127,13 @@ 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, - Table_Index_Type => Int, - Table_Low_Bound => 0, - Table_Initial => 100, - Table_Increment => 200, - Table_Name => "PSD_Pragma_Settings"); + package PSD_Pragma_Settings is new Table.Table + (Table_Component_Type => Character, + Table_Index_Type => Int, + Table_Low_Bound => 0, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "PSD_Pragma_Settings"); ---------------------------- -- Bind_Environment Table -- @@ -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#" & @@ -2580,19 +2595,20 @@ package body Bindgen is function Get_Ada_Main_Name return String is Suffix : constant String := "_00"; Name : String (1 .. Opt.Ada_Main_Name.all'Length + Suffix'Length) := - Opt.Ada_Main_Name.all & Suffix; + Opt.Ada_Main_Name.all & Suffix; Nlen : Natural; begin - -- For CodePeer, we want reproducible names (independent of other - -- mains that may or may not be present) that don't collide - -- when analyzing multiple mains and which are easily recognizable - -- as "ada_main" names. + -- For CodePeer, we want reproducible names (independent of other mains + -- that may or may not be present) that don't collide when analyzing + -- multiple mains and which are easily recognizable as "ada_main" names. if CodePeer_Mode then Get_Name_String (Units.Table (First_Unit_Entry).Uname); - return "ada_main_for_" & - Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2)); + + return + "ada_main_for_" & + Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2)); end if; -- This loop tries the following possibilities in order @@ -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; @@ -2928,9 +2945,9 @@ package body Bindgen is loop declare Inum : constant Int := - Interrupt_States.Table (K).Interrupt_Id; + Interrupt_States.Table (K).Interrupt_Id; Stat : constant Character := - Interrupt_States.Table (K).Interrupt_State; + Interrupt_States.Table (K).Interrupt_State; begin while IS_Pragma_Settings.Last < Inum loop @@ -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 diff --git a/gcc/ada/bindgen.ads b/gcc/ada/bindgen.ads index 2f4cc78..070c7fc 100644 --- a/gcc/ada/bindgen.ads +++ b/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); diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index bfb1ab4..4e1f0fc9 100644 --- a/gcc/ada/debug.adb +++ b/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). diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index d3820af..c0ff371 100644 --- a/gcc/ada/einfo.ads +++ b/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 diff --git a/gcc/ada/g-locfil.ads b/gcc/ada/g-locfil.ads index b8213cd..3e52cc0 100644 --- a/gcc/ada/g-locfil.ads +++ b/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). diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 7d98751..ebe87c1 100644 --- a/gcc/ada/gnatbind.adb +++ b/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; @@ -287,13 +276,13 @@ procedure Gnatbind is for R in All_Restrictions loop if not No_Restriction_List (R) - and then Restriction_Could_Be_Set (R) + and then Restriction_Could_Be_Set (R) then 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 @@ -582,8 +572,8 @@ begin begin pragma Assert (Shared_Libgnat_Default = SHARED - or else - Shared_Libgnat_Default = STATIC); + or else + Shared_Libgnat_Default = STATIC); Shared_Libgnat := (Shared_Libgnat_Default = SHARED); end; @@ -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; + declare + Elab_Order : Unit_Id_Table; + use Unit_Id_Tables; - -- Display list of sources in the closure (except predefined - -- sources) if -R was used. - - if List_Closure then - List_Closure_Display : declare - Source : File_Name_Type; - - function Put_In_Sources (S : File_Name_Type) return Boolean; - -- Check if S is already in table Sources and put in Sources - -- if it is not. Return False if the source is already in - -- Sources, and True if it is added. - - -------------------- - -- Put_In_Sources -- - -------------------- - - function Put_In_Sources - (S : File_Name_Type) return Boolean - is - begin - for J in 1 .. Closure_Sources.Last loop - if Closure_Sources.Table (J) = S then - return False; - end if; - end loop; - - Closure_Sources.Append (S); - return True; - end Put_In_Sources; - - -- Start of processing for List_Closure_Display - - begin - Closure_Sources.Init; - - if not Zero_Formatting then - Write_Eol; - Write_Str ("REFERENCED SOURCES"); - Write_Eol; - end if; + begin + Find_Elab_Order (Elab_Order, First_Main_Lib_File); - 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; + 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 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; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index ba47f92..55aea49 100644 --- a/gcc/ada/sem_ch13.adb +++ b/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; - if Error_Msg_Uint_1 > 0 then - Error_Msg_NE - ("?H?^-bit gap before component&", - Component_Name (Component_Clause (CEnt)), CEnt); - end if; + 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; - Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt); + if Error_Msg_Uint_1 > 0 then + Error_Msg_NE + ("?H?^-bit gap before component&", + Component_Name (Component_Clause (CEnt)), + CEnt); + end if; + + Nbit := CBO + Esize (CEnt); + end if; + end; end loop; -- Process variant parts recursively if present diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d125bf2..7cb90bf 100644 --- a/gcc/ada/sem_ch6.adb +++ b/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))); |