------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- B U T I L -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2023, 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- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Ada.Unchecked_Deallocation; with Opt; use Opt; with Output; use Output; 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 -- ---------------------- -- Note: the reason we do not use the Fname package for this function -- is that it would drag too much junk into the binder. function Is_Internal_Unit return Boolean is begin return Is_Predefined_Unit or else (Name_Len > 4 and then (Name_Buffer (1 .. 5) = "gnat%" or else Name_Buffer (1 .. 5) = "gnat.")); end Is_Internal_Unit; ------------------------ -- Is_Predefined_Unit -- ------------------------ -- Note: the reason we do not use the Fname package for this function -- is that it would drag too much junk into the binder. function Is_Predefined_Unit return Boolean is L : Natural renames Name_Len; B : String renames Name_Buffer; begin return (L > 3 and then B (1 .. 4) = "ada.") or else (L > 6 and then B (1 .. 7) = "system.") or else (L > 10 and then B (1 .. 11) = "interfaces.") or else (L > 3 and then B (1 .. 4) = "ada%") or else (L > 8 and then B (1 .. 9) = "calendar%") or else (L > 9 and then B (1 .. 10) = "direct_io%") or else (L > 10 and then B (1 .. 11) = "interfaces%") or else (L > 13 and then B (1 .. 14) = "io_exceptions%") or else (L > 12 and then B (1 .. 13) = "machine_code%") or else (L > 13 and then B (1 .. 14) = "sequential_io%") or else (L > 6 and then B (1 .. 7) = "system%") or else (L > 7 and then B (1 .. 8) = "text_io%") or else (L > 20 and then B (1 .. 21) = "unchecked_conversion%") or else (L > 22 and then B (1 .. 23) = "unchecked_deallocation%") or else (L > 4 and then B (1 .. 5) = "gnat%") 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 Ada.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 -- ---------------- function Uname_Less (U1, U2 : Unit_Name_Type) return Boolean is begin Get_Name_String (U1); declare U1_Name : constant String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len); Min_Length : Natural; begin Get_Name_String (U2); if Name_Len < U1_Name'Last then Min_Length := Name_Len; else Min_Length := U1_Name'Last; end if; for J in 1 .. Min_Length loop if U1_Name (J) > Name_Buffer (J) then return False; elsif U1_Name (J) < Name_Buffer (J) then return True; end if; end loop; return U1_Name'Last < Name_Len; end; end Uname_Less; --------------------- -- Write_Unit_Name -- --------------------- procedure Write_Unit_Name (U : Unit_Name_Type) is begin Get_Name_String (U); Write_Str (Name_Buffer (1 .. Name_Len - 2)); if Name_Buffer (Name_Len) = 's' then Write_Str (" (spec)"); else Write_Str (" (body)"); end if; Name_Len := Name_Len + 5; end Write_Unit_Name; end Butil;