From patchwork Wed Jul 3 08:30:20 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1126713 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-504267-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="MCsSaR4n"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 45dvYR6tM8z9sBp for ; Wed, 3 Jul 2019 18:34:51 +1000 (AEST) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=sE1UjQ2lysBsReVCltgrs6CzMFz8I2CdgbAcii3p4sVR9+i6gR p5Co0QamArcsNN7Cx8xNkROA67YW0rRLrbVJjeO0euuozxIDi1X7mO0Y4cirnTSz 01MfFCy+mgyLsn7SyaBD4CTzqRQZDBFrWzBCwLMoUf9OyqvibMAB2n/fk= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=GlLEn4cxoSlLrd7VIEN8L8DevP0=; b=MCsSaR4nLwreAn5J2tua kEGRIi4h4xr7olwG4pQzFF1GstwSbTvIRkpoGg4rqrRjNr/p9a1KH6/X/9PrEqnz /FZKj/412p9tW6bydPjM2W8Qko7kEdkHsIvGDQ6tIexlvPD5LZjXSmIYcTAit0KD 6IGURbT6+FMIj88/BadnvTs= Received: (qmail 48227 invoked by alias); 3 Jul 2019 08:31:07 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 46882 invoked by uid 89); 3 Jul 2019 08:31:01 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-11.7 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, KAM_NUMSUBJECT, SPF_NEUTRAL, WEIRD_QUOTING autolearn=ham version=3.3.1 spammy=vertical, Client X-HELO: eggs.gnu.org Received: from eggs.gnu.org (HELO eggs.gnu.org) (209.51.188.92) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Wed, 03 Jul 2019 08:30:53 +0000 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1hiaf9-00055q-75 for gcc-patches@gcc.gnu.org; Wed, 03 Jul 2019 04:30:51 -0400 Received: from rock.gnat.com ([2620:20:4000:0:a9e:1ff:fe9b:1d1]:58505) by eggs.gnu.org with esmtps (TLS1.0:DHE_RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1hiaf8-0004v8-Oo for gcc-patches@gcc.gnu.org; Wed, 03 Jul 2019 04:30:47 -0400 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id A7308560AB; Wed, 3 Jul 2019 04:30:20 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id s9WjLTg1od78; Wed, 3 Jul 2019 04:30:20 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 48D57560B3; Wed, 3 Jul 2019 04:30:20 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 4791C5F3; Wed, 3 Jul 2019 04:30:20 -0400 (EDT) Date: Wed, 3 Jul 2019 04:30:20 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Forced elaboration order in Elaboration order v4.0 Message-ID: <20190703083020.GA43399@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x X-Received-From: 2620:20:4000:0:a9e:1ff:fe9b:1d1 X-IsSubscribed: yes This patch refactors the forced elaboration order functionality, reintegrates it in Binde, and impelements it in Bindo. ------------ -- Source -- ------------ -- server.ads package Server is end Server; -- client.ads with Server; package Client is end Client; -- main.adb with Client; procedure Main is begin null; end Main; -- duplicate_1.txt server (spec) client (spec) server (spec) -- error_unit_1.txt no such unit client (spec) -- error_unit_2.txt no such unit client (spec) -- error_unit_3.txt no such unit -- comment client (spec) -- error_unit_4.txt no such unit -- comment client (spec) -- error_unit_5.txt no such unit (body) client (spec) -- error_unit_6.txt no such unit (body) client (spec) -- error_unit_7.txt no such unit (body) -- comment client (spec) -- error_unit_8.txt no such unit (body)-- comment client (spec) -- error_unit_9.txt no such unit-- comment client (spec) -- no_unit_1.txt -- no_unit_2.txt -- no_unit_3.txt -- comment -- no_unit_4.txt -- no_unit_5.txt -- no_unit_6.txt -- comment -- no_unit_7.txt -- no_unit_8.txt -- comment -- comment -- ok_unit_1.txt server (spec) client (spec) -- ok_unit_2.txt server (spec) client (spec) -- ok_unit_3.txt server (spec) client (spec) -- ok_unit_4.txt server (spec) -- comment client (spec) -- ok_unit_5.txt server (spec) client (spec) -- ok_unit_6.txt server (spec) client (spec) -- comment -- ok_unit_7.txt server (spec) client (spec) -- comment -- ok_unit_8.txt -- comment -- comment server (spec) -- comment -- comment client (spec) -- comment -- ok_unit_9.txt server (spec)-- comment client (spec) ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q main.adb $ gnatbind -fno_unit_1.txt main.ali $ gnatbind -fno_unit_2.txt main.ali $ gnatbind -fno_unit_3.txt main.ali $ gnatbind -fno_unit_4.txt main.ali $ gnatbind -fno_unit_5.txt main.ali $ gnatbind -fno_unit_6.txt main.ali $ gnatbind -fno_unit_7.txt main.ali $ gnatbind -fno_unit_8.txt main.ali $ gnatbind -ferror_unit_1.txt main.ali $ gnatbind -ferror_unit_2.txt main.ali $ gnatbind -ferror_unit_3.txt main.ali $ gnatbind -ferror_unit_4.txt main.ali $ gnatbind -ferror_unit_5.txt main.ali $ gnatbind -ferror_unit_6.txt main.ali $ gnatbind -ferror_unit_7.txt main.ali $ gnatbind -ferror_unit_8.txt main.ali $ gnatbind -ferror_unit_9.txt main.ali $ gnatbind -fduplicate_1.txt main.ali $ gnatbind -fok_unit_1.txt main.ali $ gnatbind -fok_unit_2.txt main.ali $ gnatbind -fok_unit_3.txt main.ali $ gnatbind -fok_unit_4.txt main.ali $ gnatbind -fok_unit_5.txt main.ali $ gnatbind -fok_unit_6.txt main.ali $ gnatbind -fok_unit_7.txt main.ali $ gnatbind -fok_unit_8.txt main.ali $ gnatbind -fok_unit_9.txt main.ali "no such unit": not present; ignored "no such unit": not present; ignored "no such unit": not present; ignored "no such unit": not present; ignored "no such unit%b": not present; ignored "no such unit%b": not present; ignored "no such unit%b": not present; ignored "no such unit%b": not present; ignored "no such unit": not present; ignored server (spec) <-- client (spec) error: duplicate_1.txt:3: duplicate unit name "server (spec)" from line 1 server (spec) <-- client (spec) server (spec) <-- client (spec) server (spec) <-- client (spec) server (spec) <-- client (spec) server (spec) <-- client (spec) server (spec) <-- client (spec) server (spec) <-- client (spec) server (spec) <-- client (spec) server (spec) <-- client (spec) Tested on x86_64-pc-linux-gnu, committed on trunk 2019-07-03 Hristian Kirtchev gcc/ada/ * binde.adb: Remove with clause for System.OS_Lib. (Force_Elab_Order): Refactor the majority of the code in Butil. Use the new forced units iterator to obtain unit names. * bindo-builders.adb: Add with and use clauses for Binderr, Butil, Opt, Output, Types, GNAT, and GNAT.Dynamic_HTables. Add a hash table which maps units to line number in the forced elaboration order file. (Add_Unit): New routine. (Build_Library_Graph): Create forced edges between pairs of units listed in the forced elaboration order file. (Create_Forced_Edge, Create_Forced_Edges, Destroy_Line_Number, Duplicate_Unit_Error, Hash_Unit, Internal_Unit_Info, Is_Duplicate_Unit, Missing_Unit_Info): New routines. * bindo-graphs.adb (Is_Internal_Unit, Is_Predefined_Unit): Refactor some of the behavior to Bindo-Units. * bindo-graphs.ads: Enable the enumeration literal for forced edges. * bindo-units.adb, bindo-units.ads (Is_Internal_Unit, Is_Predefined_Unit): New routines. * butil.adb: Add with and use clauses for Opt, GNAT, and System.OS_Lib. Add with clause for Unchecked_Deallocation. (Has_Next, Iterate_Forced_Units, Next, Parse_Next_Unit_Name, Read_Forced_Elab_Order_File): New routines. * butil.ads: Add with and use clauses for Types. Add new iterator over the units listed in the forced elaboration order file. (Has_Next, Iterate_Forced_Units, Next): New routine. * namet.adb, namet.ads (Present): New routine. --- gcc/ada/binde.adb +++ gcc/ada/binde.adb @@ -35,7 +35,6 @@ with Types; use Types; with System.Case_Util; use System.Case_Util; with System.HTable; -with System.OS_Lib; package body Binde is use Unit_Id_Tables; @@ -115,7 +114,7 @@ package body Binde is -- elaborated before After is elaborated. Forced, - -- Before and After come from a pair of lines in the forced elaboration + -- Before and After come from a pair of lines in the forced-elaboration- -- order file. Elab, @@ -382,7 +381,7 @@ package body Binde is -- "$ must be elaborated before $ ..." where ... is the reason. procedure Force_Elab_Order; - -- Gather dependencies from the forced elaboration order file (-f switch) + -- Gather dependencies from the forced-elaboration-order file (-f switch) procedure Gather_Dependencies; -- Compute dependencies, building the Succ and UNR tables @@ -1795,30 +1794,13 @@ package body Binde is ---------------------- procedure Force_Elab_Order is - use System.OS_Lib; - -- There is a lot of fiddly string manipulation below, because we don't - -- want to depend on misc utility packages like Ada.Characters.Handling. - - function Get_Line return String; - -- Read the next line from the file content read by Read_File. Strip - -- 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; - -- Read the entire contents of the named file - subtype Header_Num is Unit_Name_Type'Base range 0 .. 2**16 - 1; - type Line_Number is new Nat; - No_Line_Number : constant Line_Number := 0; - Cur_Line_Number : Line_Number := 0; - -- Current line number in the Force_Elab_Order_File. - -- Incremented by Get_Line. Used in error messages. function Hash (N : Unit_Name_Type) return Header_Num; package Name_Map is new System.HTable.Simple_HTable (Header_Num => Header_Num, - Element => Line_Number, + Element => Logical_Line_Number, No_Element => No_Line_Number, Key => Unit_Name_Type, Hash => Hash, @@ -1839,234 +1821,86 @@ package body Binde is return (N - Unit_Name_Type'First) mod (Header_Num'Last + 1); end Hash; - --------------- - -- Read_File -- - --------------- - - 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. - - F : constant File_Descriptor := Open_Read (Name, Binary); - - begin - if F = Invalid_FD then - raise Program_Error; - end if; - - declare - Len : constant Natural := Natural (File_Length (F)); - Result : constant String_Ptr := new String (1 .. Len); - Len_Read : constant Natural := - Read (F, Result (1)'Address, Len); - - Status : Boolean; - - begin - if Len_Read /= Len then - raise Program_Error; - end if; - - Close (F, Status); - - if not Status then - raise Program_Error; - end if; - - return Result; - end; - end Read_File; - - Cur : Positive := 1; - S : String_Ptr := Read_File (Force_Elab_Order_File.all); - - -------------- - -- Get_Line -- - -------------- - - function Get_Line return String is - First : Positive := Cur; - Last : Natural; - - begin - Cur_Line_Number := Cur_Line_Number + 1; - - -- Skip to end of line - - while Cur <= S'Last - and then S (Cur) /= ASCII.LF - and then S (Cur) /= ASCII.CR - loop - Cur := Cur + 1; - end loop; - - -- Strip leading blanks - - while First <= S'Last and then S (First) = ' ' loop - First := First + 1; - end loop; - - -- Strip trailing blanks and comment + -- Local variables - Last := Cur - 1; + Cur_Line_Number : Logical_Line_Number; + Error : Boolean := False; + Iter : Forced_Units_Iterator; + Prev_Unit : Unit_Id := No_Unit_Id; + Uname : Unit_Name_Type; - for J in First .. Last - 1 loop - if S (J .. J + 1) = "--" then - Last := J - 1; - exit; - end if; - end loop; - - while Last >= First and then S (Last) = ' ' loop - Last := Last - 1; - end loop; + -- Start of processing for Force_Elab_Order - -- Convert "(spec)" or "(body)" to "%s"/"%b", strip trailing blanks - -- again. + begin + Iter := Iterate_Forced_Units; + while Has_Next (Iter) loop + Next (Iter, Uname, Cur_Line_Number); declare - Body_String : constant String := "(body)"; - BL : constant Positive := Body_String'Length; - Spec_String : constant String := "(spec)"; - SL : constant Positive := Spec_String'Length; - - Line : String renames S (First .. Last); - - Is_Body : Boolean := False; - Is_Spec : Boolean := False; - + Dup : constant Logical_Line_Number := Name_Map.Get (Uname); begin - if Line'Length >= SL - and then Line (Last - SL + 1 .. Last) = Spec_String - then - Is_Spec := True; - Last := Last - SL; - elsif Line'Length >= BL - and then Line (Last - BL + 1 .. Last) = Body_String - then - Is_Body := True; - Last := Last - BL; - end if; - - while Last >= First and then S (Last) = ' ' loop - Last := Last - 1; - end loop; + if Dup = No_Line_Number then + Name_Map.Set (Uname, Cur_Line_Number); - -- Skip past LF or CR/LF + -- We don't need to give the "not present" message in the case + -- of "duplicate unit", because we would have already given the + -- "not present" message on the first occurrence. - if Cur <= S'Last and then S (Cur) = ASCII.CR then - Cur := Cur + 1; - end if; - - if Cur <= S'Last and then S (Cur) = ASCII.LF then - Cur := Cur + 1; - end if; + if Get_Name_Table_Int (Uname) = 0 + or else Unit_Id (Get_Name_Table_Int (Uname)) = No_Unit_Id + then + Error := True; + if Doing_New then + Write_Line + ("""" & Get_Name_String (Uname) + & """: not present; ignored"); + end if; + end if; - if Is_Spec then - return Line (First .. Last) & "%s"; - elsif Is_Body then - return Line (First .. Last) & "%b"; else - return Line; + Error := True; + if Doing_New then + Error_Msg_Nat_1 := Nat (Cur_Line_Number); + Error_Msg_Unit_1 := Uname; + Error_Msg_Nat_2 := Nat (Dup); + Error_Msg + (Force_Elab_Order_File.all + & ":#: duplicate unit name $ from line #"); + end if; end if; end; - end Get_Line; - -- Local variables - - Empty_Name : constant Unit_Name_Type := Name_Find (""); - Prev_Unit : Unit_Id := No_Unit_Id; - - -- Start of processing for Force_Elab_Order - - begin - -- Loop through the file content, and build a dependency link for each - -- pair of lines. Ignore lines that should be ignored. - - while Cur <= S'Last loop - declare - Uname : constant Unit_Name_Type := Name_Find (Get_Line); - Error : Boolean := False; - - begin - if Uname = Empty_Name then - null; -- silently skip blank lines - else - declare - Dup : constant Line_Number := Name_Map.Get (Uname); - begin - if Dup = No_Line_Number then - Name_Map.Set (Uname, Cur_Line_Number); - - -- We don't need to give the "not present" message in - -- the case of "duplicate unit", because we would have - -- already given the "not present" message on the - -- first occurrence. - - if Get_Name_Table_Int (Uname) = 0 - or else Unit_Id (Get_Name_Table_Int (Uname)) = - No_Unit_Id - then - Error := True; - if Doing_New then - Write_Line - ("""" & Get_Name_String (Uname) - & """: not present; ignored"); - end if; - end if; + if not Error then + declare + Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname); + begin + if Is_Internal_File_Name (Units.Table (Cur_Unit).Sfile) then + if Doing_New then + Write_Line + ("""" & Get_Name_String (Uname) + & """: predefined unit ignored"); + end if; - else - Error := True; + else + if Prev_Unit /= No_Unit_Id then if Doing_New then - Error_Msg_Nat_1 := Nat (Cur_Line_Number); - Error_Msg_Unit_1 := Uname; - Error_Msg_Nat_2 := Nat (Dup); - Error_Msg - (Force_Elab_Order_File.all - & ":#: duplicate unit name $ from line #"); + Write_Unit_Name (Units.Table (Prev_Unit).Uname); + Write_Str (" <-- "); + Write_Unit_Name (Units.Table (Cur_Unit).Uname); + Write_Eol; end if; - end if; - end; - - if not Error then - declare - Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname); - begin - if Is_Internal_File_Name - (Units.Table (Cur_Unit).Sfile) - then - if Doing_New then - Write_Line - ("""" & Get_Name_String (Uname) - & """: predefined unit ignored"); - end if; - else - if Prev_Unit /= No_Unit_Id then - if Doing_New then - Write_Unit_Name (Units.Table (Prev_Unit).Uname); - Write_Str (" <-- "); - Write_Unit_Name (Units.Table (Cur_Unit).Uname); - Write_Eol; - end if; - - Build_Link - (Before => Prev_Unit, - After => Cur_Unit, - R => Forced); - end if; + Build_Link + (Before => Prev_Unit, + After => Cur_Unit, + R => Forced); + end if; - Prev_Unit := Cur_Unit; - end if; - end; + Prev_Unit := Cur_Unit; end if; - end if; - end; + end; + end if; end loop; - - Free (S); end Force_Elab_Order; ------------------------- --- gcc/ada/bindo-builders.adb +++ gcc/ada/bindo-builders.adb @@ -23,8 +23,17 @@ -- -- ------------------------------------------------------------------------------ +with Binderr; use Binderr; +with Butil; use Butil; +with Opt; use Opt; +with Output; use Output; +with Types; use Types; + with Bindo.Units; use Bindo.Units; +with GNAT; use GNAT; +with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; + package body Bindo.Builders is ------------------------------- @@ -214,16 +223,63 @@ package body Bindo.Builders is package body Library_Graph_Builders is + --------------------- + -- Data structures -- + --------------------- + + procedure Destroy_Line_Number (Line : in out Logical_Line_Number); + pragma Inline (Destroy_Line_Number); + -- Destroy line number Line + + function Hash_Unit (U_Id : Unit_Id) return Bucket_Range_Type; + pragma Inline (Hash_Unit); + -- Obtain the hash value of key U_Id + + package UL is new Dynamic_Hash_Tables + (Key_Type => Unit_Id, + Value_Type => Logical_Line_Number, + No_Value => No_Line_Number, + Expansion_Threshold => 1.5, + Expansion_Factor => 2, + Compression_Threshold => 0.3, + Compression_Factor => 2, + "=" => "=", + Destroy_Value => Destroy_Line_Number, + Hash => Hash_Unit); + ----------------- -- Global data -- ----------------- Lib_Graph : Library_Graph := Library_Graphs.Nil; + Unit_To_Line : UL.Dynamic_Hash_Table := UL.Nil; + -- The map of unit name -> line number, used to detect duplicate unit + -- names and report errors. + ----------------------- -- Local subprograms -- ----------------------- + procedure Add_Unit + (U_Id : Unit_Id; + Line : Logical_Line_Number); + pragma Inline (Add_Unit); + -- Create a relationship between unit U_Id and its declaration line in + -- map Unit_To_Line. + + procedure Create_Forced_Edge + (Pred : Unit_Id; + Succ : Unit_Id); + pragma Inline (Create_Forced_Edge); + -- Create a new forced edge between predecessor unit Pred and successor + -- unit Succ. + + procedure Create_Forced_Edges; + pragma Inline (Create_Forced_Edges); + -- Inspect the contents of the forced-elaboration-order file, and create + -- specialized edges for each valid pair of units listed within. + procedure Create_Spec_And_Body_Edge (U_Id : Unit_Id); pragma Inline (Create_Spec_And_Body_Edge); -- Establish a link between the spec and body of unit U_Id. In certain @@ -255,10 +311,46 @@ package body Bindo.Builders is -- some withed unit, and the successor is Succ. The edges are added to -- library graph Lib_Graph. + procedure Duplicate_Unit_Error + (U_Id : Unit_Id; + Nam : Unit_Name_Type; + Line : Logical_Line_Number); + pragma Inline (Duplicate_Unit_Error); + -- Emit an error concerning the duplication of unit U_Id with name Nam + -- that is redeclared in the forced-elaboration-order file at line Line. + + procedure Internal_Unit_Info (Nam : Unit_Name_Type); + pragma Inline (Internal_Unit_Info); + -- Emit an information message concerning the omission of an internal + -- unit with name Nam from the creation of forced edges. + + function Is_Duplicate_Unit (U_Id : Unit_Id) return Boolean; + pragma Inline (Is_Duplicate_Unit); + -- Determine whether unit U_Id is already recorded in map Unit_To_Line + function Is_Significant_With (W_Id : With_Id) return Boolean; pragma Inline (Is_Significant_With); -- Determine whether with W_Id plays a significant role in elaboration + procedure Missing_Unit_Info (Nam : Unit_Name_Type); + pragma Inline (Missing_Unit_Info); + -- Emit an information message concerning the omission of an undefined + -- unit found in the forced-elaboration-order file. + + -------------- + -- Add_Unit -- + -------------- + + procedure Add_Unit + (U_Id : Unit_Id; + Line : Logical_Line_Number) + is + begin + pragma Assert (Present (U_Id)); + + UL.Put (Unit_To_Line, U_Id, Line); + end Add_Unit; + ------------------------- -- Build_Library_Graph -- ------------------------- @@ -275,9 +367,96 @@ package body Bindo.Builders is For_Each_Elaborable_Unit (Create_Spec_And_Body_Edge'Access); For_Each_Elaborable_Unit (Create_With_Edges'Access); + Create_Forced_Edges; + return Lib_Graph; end Build_Library_Graph; + ------------------------ + -- Create_Forced_Edge -- + ------------------------ + + procedure Create_Forced_Edge + (Pred : Unit_Id; + Succ : Unit_Id) + is + pragma Assert (Present (Pred)); + pragma Assert (Present (Succ)); + + Pred_LGV_Id : constant Library_Graph_Vertex_Id := + Corresponding_Vertex (Lib_Graph, Pred); + Succ_LGV_Id : constant Library_Graph_Vertex_Id := + Corresponding_Vertex (Lib_Graph, Succ); + + pragma Assert (Present (Pred_LGV_Id)); + pragma Assert (Present (Succ_LGV_Id)); + + begin + Write_Unit_Name (Name (Pred)); + Write_Str (" <-- "); + Write_Unit_Name (Name (Succ)); + Write_Eol; + + Add_Edge + (G => Lib_Graph, + Pred => Pred_LGV_Id, + Succ => Succ_LGV_Id, + Kind => Forced_Edge); + end Create_Forced_Edge; + + ------------------------- + -- Create_Forced_Edges -- + ------------------------- + + procedure Create_Forced_Edges is + Curr_Unit : Unit_Id; + Iter : Forced_Units_Iterator; + Prev_Unit : Unit_Id; + Unit_Line : Logical_Line_Number; + Unit_Name : Unit_Name_Type; + + begin + Prev_Unit := No_Unit_Id; + Unit_To_Line := UL.Create (20); + + -- Inspect the contents of the forced-elaboration-order file supplied + -- to the binder using switch -f, and diagnose each unit accordingly. + + Iter := Iterate_Forced_Units; + while Has_Next (Iter) loop + Next (Iter, Unit_Name, Unit_Line); + pragma Assert (Present (Unit_Name)); + + Curr_Unit := Corresponding_Unit (Unit_Name); + + if not Present (Curr_Unit) then + Missing_Unit_Info (Unit_Name); + + elsif Is_Internal_Unit (Curr_Unit) then + Internal_Unit_Info (Unit_Name); + + elsif Is_Duplicate_Unit (Curr_Unit) then + Duplicate_Unit_Error (Curr_Unit, Unit_Name, Unit_Line); + + -- Otherwise the unit is a valid candidate for a vertex. Create a + -- forced edge between each pair of units. + + else + Add_Unit (Curr_Unit, Unit_Line); + + if Present (Prev_Unit) then + Create_Forced_Edge + (Pred => Prev_Unit, + Succ => Curr_Unit); + end if; + + Prev_Unit := Curr_Unit; + end if; + end loop; + + UL.Destroy (Unit_To_Line); + end Create_Forced_Edges; + ------------------------------- -- Create_Spec_And_Body_Edge -- ------------------------------- @@ -453,6 +632,75 @@ package body Bindo.Builders is end loop; end Create_With_Edges; + ------------------ + -- Destroy_Unit -- + ------------------ + + procedure Destroy_Line_Number (Line : in out Logical_Line_Number) is + pragma Unreferenced (Line); + begin + null; + end Destroy_Line_Number; + + -------------------------- + -- Duplicate_Unit_Error -- + -------------------------- + + procedure Duplicate_Unit_Error + (U_Id : Unit_Id; + Nam : Unit_Name_Type; + Line : Logical_Line_Number) + is + pragma Assert (Present (U_Id)); + pragma Assert (Present (Nam)); + + Prev_Line : constant Logical_Line_Number := + UL.Get (Unit_To_Line, U_Id); + + begin + Error_Msg_Nat_1 := Nat (Line); + Error_Msg_Nat_2 := Nat (Prev_Line); + Error_Msg_Unit_1 := Nam; + + Error_Msg + (Force_Elab_Order_File.all + & ":#: duplicate unit name $ from line #"); + end Duplicate_Unit_Error; + + --------------- + -- Hash_Unit -- + --------------- + + function Hash_Unit (U_Id : Unit_Id) return Bucket_Range_Type is + begin + pragma Assert (Present (U_Id)); + + return Bucket_Range_Type (U_Id); + end Hash_Unit; + + ------------------------ + -- Internal_Unit_Info -- + ------------------------ + + procedure Internal_Unit_Info (Nam : Unit_Name_Type) is + begin + pragma Assert (Present (Nam)); + + Write_Line + ("""" & Get_Name_String (Nam) & """: predefined unit ignored"); + end Internal_Unit_Info; + + ----------------------- + -- Is_Duplicate_Unit -- + ----------------------- + + function Is_Duplicate_Unit (U_Id : Unit_Id) return Boolean is + begin + pragma Assert (Present (U_Id)); + + return UL.Contains (Unit_To_Line, U_Id); + end Is_Duplicate_Unit; + ------------------------- -- Is_Significant_With -- ------------------------- @@ -483,6 +731,18 @@ package body Bindo.Builders is return True; end Is_Significant_With; + + ----------------------- + -- Missing_Unit_Info -- + ----------------------- + + procedure Missing_Unit_Info (Nam : Unit_Name_Type) is + begin + pragma Assert (Present (Nam)); + + Write_Line + ("""" & Get_Name_String (Nam) & """: not present; ignored"); + end Missing_Unit_Info; end Library_Graph_Builders; end Bindo.Builders; --- gcc/ada/bindo-graphs.adb +++ gcc/ada/bindo-graphs.adb @@ -2069,10 +2069,8 @@ package body Bindo.Graphs is pragma Assert (Present (U_Id)); - U_Rec : Unit_Record renames ALI.Units.Table (U_Id); - begin - return U_Rec.Internal; + return Is_Internal_Unit (U_Id); end Is_Internal_Unit; ------------------------ @@ -2090,10 +2088,8 @@ package body Bindo.Graphs is pragma Assert (Present (U_Id)); - U_Rec : Unit_Record renames ALI.Units.Table (U_Id); - begin - return U_Rec.Predefined; + return Is_Predefined_Unit (U_Id); end Is_Predefined_Unit; --------------------------- --- gcc/ada/bindo-graphs.ads +++ gcc/ada/bindo-graphs.ads @@ -573,7 +573,7 @@ package Bindo.Graphs is Elaborate_All_Edge, -- Successor withs Predecessor, and has pragma Elaborate_All for it --- Forced_Edge, + Forced_Edge, -- Successor is forced to with Predecessor by virtue of an existing -- elaboration order provided in a file. --- gcc/ada/bindo-units.adb +++ gcc/ada/bindo-units.adb @@ -233,6 +233,32 @@ package body Bindo.Units is return U_Rec.Dynamic_Elab; end Is_Dynamically_Elaborated; + ---------------------- + -- Is_Internal_Unit -- + ---------------------- + + function Is_Internal_Unit (U_Id : Unit_Id) return Boolean is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + return U_Rec.Internal; + end Is_Internal_Unit; + + ------------------------ + -- Is_Predefined_Unit -- + ------------------------ + + function Is_Predefined_Unit (U_Id : Unit_Id) return Boolean is + pragma Assert (Present (U_Id)); + + U_Rec : Unit_Record renames ALI.Units.Table (U_Id); + + begin + return U_Rec.Predefined; + end Is_Predefined_Unit; + --------------------------------- -- Is_Stand_Alone_Library_Unit -- --------------------------------- --- gcc/ada/bindo-units.ads +++ gcc/ada/bindo-units.ads @@ -78,6 +78,14 @@ package Bindo.Units is -- Determine whether unit U_Id was compiled using the dynamic elaboration -- model. + function Is_Internal_Unit (U_Id : Unit_Id) return Boolean; + pragma Inline (Is_Internal_Unit); + -- Determine whether unit U_Id is internal + + function Is_Predefined_Unit (U_Id : Unit_Id) return Boolean; + pragma Inline (Is_Predefined_Unit); + -- Determine whether unit U_Id is predefined + function Name (U_Id : Unit_Id) return Unit_Name_Type; pragma Inline (Name); -- Obtain the name of unit U_Id --- gcc/ada/butil.adb +++ gcc/ada/butil.adb @@ -23,10 +23,38 @@ -- -- ------------------------------------------------------------------------------ +with Opt; use Opt; with Output; use Output; +with Unchecked_Deallocation; + +with GNAT; use GNAT; + +with System.OS_Lib; use System.OS_Lib; package body Butil is + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Parse_Next_Unit_Name (Iter : in out Forced_Units_Iterator); + -- Parse the name of the next available unit accessible through iterator + -- Iter and save it in the iterator. + + function Read_Forced_Elab_Order_File return String_Ptr; + -- Read the contents of the forced-elaboration-order file supplied to the + -- binder via switch -f and return them as a string. Return null if the + -- file is not available. + + -------------- + -- Has_Next -- + -------------- + + function Has_Next (Iter : Forced_Units_Iterator) return Boolean is + begin + return Present (Iter.Unit_Name); + end Has_Next; + ---------------------- -- Is_Internal_Unit -- ---------------------- @@ -71,6 +99,499 @@ package body Butil is or else (L > 4 and then B (1 .. 5) = "gnat."); end Is_Predefined_Unit; + -------------------------- + -- Iterate_Forced_Units -- + -------------------------- + + function Iterate_Forced_Units return Forced_Units_Iterator is + Iter : Forced_Units_Iterator; + + begin + Iter.Order := Read_Forced_Elab_Order_File; + Parse_Next_Unit_Name (Iter); + + return Iter; + end Iterate_Forced_Units; + + ---------- + -- Next -- + ---------- + + procedure Next + (Iter : in out Forced_Units_Iterator; + Unit_Name : out Unit_Name_Type; + Unit_Line : out Logical_Line_Number) + is + begin + if not Has_Next (Iter) then + raise Iterator_Exhausted; + end if; + + Unit_Line := Iter.Unit_Line; + Unit_Name := Iter.Unit_Name; + pragma Assert (Present (Unit_Name)); + + Parse_Next_Unit_Name (Iter); + end Next; + + -------------------------- + -- Parse_Next_Unit_Name -- + -------------------------- + + procedure Parse_Next_Unit_Name (Iter : in out Forced_Units_Iterator) is + Body_Suffix : constant String := " (body)"; + Body_Type : constant String := "%b"; + Body_Length : constant Positive := Body_Suffix'Length; + Body_Offset : constant Natural := Body_Length - 1; + + Comment_Header : constant String := "--"; + Comment_Offset : constant Natural := Comment_Header'Length - 1; + + Spec_Suffix : constant String := " (spec)"; + Spec_Type : constant String := "%s"; + Spec_Length : constant Positive := Spec_Suffix'Length; + Spec_Offset : constant Natural := Spec_Length - 1; + + Index : Positive renames Iter.Order_Index; + Line : Logical_Line_Number renames Iter.Order_Line; + Order : String_Ptr renames Iter.Order; + + function At_Comment return Boolean; + pragma Inline (At_Comment); + -- Determine whether iterator Iter is positioned over the start of a + -- comment. + + function At_Terminator return Boolean; + pragma Inline (At_Terminator); + -- Determine whether iterator Iter is positioned over a line terminator + -- character. + + function At_Whitespace return Boolean; + pragma Inline (At_Whitespace); + -- Determine whether iterator Iter is positioned over a whitespace + -- character. + + function Is_Terminator (C : Character) return Boolean; + pragma Inline (Is_Terminator); + -- Determine whether character C denotes a line terminator + + function Is_Whitespace (C : Character) return Boolean; + pragma Inline (Is_Whitespace); + -- Determine whether character C denotes a whitespace + + procedure Parse_Unit_Name; + pragma Inline (Parse_Unit_Name); + -- Find and parse the first available unit name + + procedure Skip_Comment; + pragma Inline (Skip_Comment); + -- Skip a comment by reaching a line terminator + + procedure Skip_Terminator; + pragma Inline (Skip_Terminator); + -- Skip a line terminator and deal with the logical line numbering + + procedure Skip_Whitespace; + pragma Inline (Skip_Whitespace); + -- Skip whitespace + + function Within_Order + (Low_Offset : Natural := 0; + High_Offset : Natural := 0) return Boolean; + pragma Inline (Within_Order); + -- Determine whether index of iterator Iter is still within the range of + -- the order string. Low_Offset may be used to inspect the area that is + -- less than the index. High_Offset may be used to inspect the area that + -- is greater than the index. + + ---------------- + -- At_Comment -- + ---------------- + + function At_Comment return Boolean is + begin + -- The interator is over a comment when the index is positioned over + -- the start of a comment header. + -- + -- unit (spec) -- comment + -- ^ + -- Index + + return + Within_Order (High_Offset => Comment_Offset) + and then Order (Index .. Index + Comment_Offset) = Comment_Header; + end At_Comment; + + ------------------- + -- At_Terminator -- + ------------------- + + function At_Terminator return Boolean is + begin + return Within_Order and then Is_Terminator (Order (Index)); + end At_Terminator; + + ------------------- + -- At_Whitespace -- + ------------------- + + function At_Whitespace return Boolean is + begin + return Within_Order and then Is_Whitespace (Order (Index)); + end At_Whitespace; + + ------------------- + -- Is_Terminator -- + ------------------- + + function Is_Terminator (C : Character) return Boolean is + begin + -- Carriage return is treated intentionally as whitespace since it + -- appears only on certain targets, while line feed is consistent on + -- all of them. + + return C = ASCII.LF; + end Is_Terminator; + + ------------------- + -- Is_Whitespace -- + ------------------- + + function Is_Whitespace (C : Character) return Boolean is + begin + return + C = ' ' + or else C = ASCII.CR -- carriage return + or else C = ASCII.FF -- form feed + or else C = ASCII.HT -- horizontal tab + or else C = ASCII.VT; -- vertical tab + end Is_Whitespace; + + --------------------- + -- Parse_Unit_Name -- + --------------------- + + procedure Parse_Unit_Name is + pragma Assert (not At_Comment); + pragma Assert (not At_Terminator); + pragma Assert (not At_Whitespace); + pragma Assert (Within_Order); + + procedure Find_End_Index_Of_Unit_Name; + pragma Inline (Find_End_Index_Of_Unit_Name); + -- Position the index of iterator Iter at the last character of the + -- first available unit name. + + --------------------------------- + -- Find_End_Index_Of_Unit_Name -- + --------------------------------- + + procedure Find_End_Index_Of_Unit_Name is + begin + -- At this point the index points at the start of a unit name. The + -- unit name may be legal, in which case it appears as: + -- + -- unit (body) + -- + -- However, it may also be illegal: + -- + -- unit without suffix + -- unit with multiple prefixes (spec) + -- + -- In order to handle both forms, find the construct following the + -- unit name. This is either a comment, a terminator, or the end + -- of the order: + -- + -- unit (body) -- comment + -- unit without suffix + -- unit with multiple prefixes (spec) + -- + -- Once the construct is found, truncate the unit name by skipping + -- all white space between the construct and the end of the unit + -- name. + + -- Find the construct that follows the unit name + + while Within_Order loop + if At_Comment then + exit; + + elsif At_Terminator then + exit; + end if; + + Index := Index + 1; + end loop; + + -- Position the index prior to the construct that follows the unit + -- name. + + Index := Index - 1; + + -- Truncate towards the end of the unit name + + while Within_Order loop + if At_Whitespace then + Index := Index - 1; + else + exit; + end if; + end loop; + end Find_End_Index_Of_Unit_Name; + + -- Local variables + + Start_Index : constant Positive := Index; + + End_Index : Positive; + Is_Body : Boolean := False; + Is_Spec : Boolean := False; + + -- Start of processing for Parse_Unit_Name + + begin + Find_End_Index_Of_Unit_Name; + End_Index := Index; + + pragma Assert (Start_Index <= End_Index); + + -- At this point the indices are positioned as follows: + -- + -- End_Index + -- Index + -- v + -- unit (spec) -- comment + -- ^ + -- Start_Index + + -- Rewind the index, skipping over the legal suffixes + -- + -- Index End_Index + -- v v + -- unit (spec) -- comment + -- ^ + -- Start_Index + + if Within_Order (Low_Offset => Body_Offset) + and then Order (Index - Body_Offset .. Index) = Body_Suffix + then + Is_Body := True; + Index := Index - Body_Length; + + elsif Within_Order (Low_Offset => Spec_Offset) + and then Order (Index - Spec_Offset .. Index) = Spec_Suffix + then + Is_Spec := True; + Index := Index - Spec_Length; + end if; + + -- Capture the line where the unit name is defined + + Iter.Unit_Line := Line; + + -- Transform the unit name to match the format recognized by the + -- name table. + + if Is_Body then + Iter.Unit_Name := + Name_Find (Order (Start_Index .. Index) & Body_Type); + + elsif Is_Spec then + Iter.Unit_Name := + Name_Find (Order (Start_Index .. Index) & Spec_Type); + + -- Otherwise the unit name is illegal, so leave it as is + + else + Iter.Unit_Name := Name_Find (Order (Start_Index .. Index)); + end if; + + -- Advance the index past the unit name + -- + -- End_IndexIndex + -- vv + -- unit (spec) -- comment + -- ^ + -- Start_Index + + Index := End_Index + 1; + end Parse_Unit_Name; + + ------------------ + -- Skip_Comment -- + ------------------ + + procedure Skip_Comment is + begin + pragma Assert (At_Comment); + + while Within_Order loop + if At_Terminator then + exit; + end if; + + Index := Index + 1; + end loop; + end Skip_Comment; + + --------------------- + -- Skip_Terminator -- + --------------------- + + procedure Skip_Terminator is + begin + pragma Assert (At_Terminator); + + Index := Index + 1; + Line := Line + 1; + end Skip_Terminator; + + --------------------- + -- Skip_Whitespace -- + --------------------- + + procedure Skip_Whitespace is + begin + while Within_Order loop + if At_Whitespace then + Index := Index + 1; + else + exit; + end if; + end loop; + end Skip_Whitespace; + + ------------------ + -- Within_Order -- + ------------------ + + function Within_Order + (Low_Offset : Natural := 0; + High_Offset : Natural := 0) return Boolean + is + begin + return + Order /= null + and then Index - Low_Offset >= Order'First + and then Index + High_Offset <= Order'Last; + end Within_Order; + + -- Start of processing for Parse_Next_Unit_Name + + begin + -- A line in the forced-elaboration-order file has the following + -- grammar: + -- + -- LINE ::= + -- [WHITESPACE] UNIT_NAME [WHITESPACE] [COMMENT] TERMINATOR + -- + -- WHITESPACE ::= + -- + -- | + -- + -- UNIT_NAME ::= + -- UNIT_PREFIX [WHITESPACE] UNIT_SUFFIX + -- + -- UNIT_PREFIX ::= + -- + -- + -- UNIT_SUFFIX ::= + -- (body) + -- | (spec) + -- + -- COMMENT ::= + -- -- + -- + -- TERMINATOR ::= + -- + -- + -- + -- Items in <> brackets are semantic notions + + -- Assume that the order has no remaining units + + Iter.Unit_Line := No_Line_Number; + Iter.Unit_Name := No_Unit_Name; + + -- Try to find the first available unit name from the current position + -- of iteration. + + while Within_Order loop + Skip_Whitespace; + + if At_Comment then + Skip_Comment; + + elsif not Within_Order then + exit; + + elsif At_Terminator then + Skip_Terminator; + + else + Parse_Unit_Name; + exit; + end if; + end loop; + end Parse_Next_Unit_Name; + + --------------------------------- + -- Read_Forced_Elab_Order_File -- + --------------------------------- + + function Read_Forced_Elab_Order_File return String_Ptr is + procedure Free is new Unchecked_Deallocation (String, String_Ptr); + + Descr : File_Descriptor; + Len : Natural; + Len_Read : Natural; + Result : String_Ptr; + Success : Boolean; + + begin + if Force_Elab_Order_File = null then + return null; + end if; + + -- Obtain and sanitize a descriptor to the elaboration-order file + + Descr := Open_Read (Force_Elab_Order_File.all, Binary); + + if Descr = Invalid_FD then + return null; + end if; + + -- Determine the size of the file, allocate a result large enough to + -- house its contents, and read it. + + Len := Natural (File_Length (Descr)); + + if Len = 0 then + return null; + end if; + + Result := new String (1 .. Len); + Len_Read := Read (Descr, Result (1)'Address, Len); + + -- The read failed to acquire the whole content of the file + + if Len_Read /= Len then + Free (Result); + return null; + end if; + + Close (Descr, Success); + + -- The file failed to close + + if not Success then + Free (Result); + return null; + end if; + + return Result; + end Read_Forced_Elab_Order_File; + ---------------- -- Uname_Less -- ---------------- --- gcc/ada/butil.ads +++ gcc/ada/butil.ads @@ -23,12 +23,13 @@ -- -- ------------------------------------------------------------------------------ +-- This package contains utility routines for the binder + with Namet; use Namet; +with Types; use Types; package Butil is --- This package contains utility routines for the binder - function Is_Predefined_Unit return Boolean; -- Given a unit name stored in Name_Buffer with length in Name_Len, -- returns True if this is the name of a predefined unit or a child of @@ -51,4 +52,52 @@ package Butil is -- Output unit name with (body) or (spec) after as required. On return -- Name_Len is set to the number of characters which were output. + --------------- + -- Iterators -- + --------------- + + -- The following type represents an iterator over all units that are + -- specified in the forced-elaboration-order file supplied by the binder + -- via switch -f. + + type Forced_Units_Iterator is private; + + function Has_Next (Iter : Forced_Units_Iterator) return Boolean; + pragma Inline (Has_Next); + -- Determine whether iterator Iter has more units to examine + + function Iterate_Forced_Units return Forced_Units_Iterator; + pragma Inline (Iterate_Forced_Units); + -- Obtain an iterator over all units in the forced-elaboration-order file + + procedure Next + (Iter : in out Forced_Units_Iterator; + Unit_Name : out Unit_Name_Type; + Unit_Line : out Logical_Line_Number); + pragma Inline (Next); + -- Return the current unit referenced by iterator Iter along with the + -- line number it appears on, and advance to the next available unit. + +private + First_Line_Number : constant Logical_Line_Number := No_Line_Number + 1; + + type Forced_Units_Iterator is record + Order : String_Ptr := null; + -- A reference to the contents of the forced-elaboration-order file, + -- read in as a string. + + Order_Index : Positive := 1; + -- Index into the order string + + Order_Line : Logical_Line_Number := First_Line_Number; + -- Logical line number within the order string + + Unit_Line : Logical_Line_Number := No_Line_Number; + -- The logical line number of the current unit name within the order + -- string. + + Unit_Name : Unit_Name_Type := No_Unit_Name; + -- The current unit name parsed from the order string + end record; + end Butil; --- gcc/ada/namet.adb +++ gcc/ada/namet.adb @@ -1515,6 +1515,15 @@ package body Namet is return Nam /= No_Name; end Present; + ------------- + -- Present -- + ------------- + + function Present (Nam : Unit_Name_Type) return Boolean is + begin + return Nam /= No_Unit_Name; + end Present; + ------------------ -- Reinitialize -- ------------------ --- gcc/ada/namet.ads +++ gcc/ada/namet.ads @@ -658,6 +658,10 @@ package Namet is No_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (No_Name); -- Constant used to indicate no file name present + function Present (Nam : Unit_Name_Type) return Boolean; + pragma Inline (Present); + -- Determine whether unit name Nam exists + Error_Unit_Name : constant Unit_Name_Type := Unit_Name_Type (Error_Name); -- The special Unit_Name_Type value Error_Unit_Name is used to indicate -- a unit name where some previous processing has found an error.