diff options
Diffstat (limited to 'gcc/ada/bld-io.adb')
| -rw-r--r-- | gcc/ada/bld-io.adb | 285 |
1 files changed, 0 insertions, 285 deletions
diff --git a/gcc/ada/bld-io.adb b/gcc/ada/bld-io.adb deleted file mode 100644 index 7bd01e6ac6d..00000000000 --- a/gcc/ada/bld-io.adb +++ /dev/null @@ -1,285 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- B L D - I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2003 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 2, 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 COPYING. If not, write -- --- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- --- MA 02111-1307, USA. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; -with Ada.Text_IO; -with Ada.Unchecked_Deallocation; - -with GNAT.OS_Lib; use GNAT.OS_Lib; -with Osint; - -package body Bld.IO is - - use Ada; - - Initial_Number_Of_Lines : constant := 100; - Initial_Length_Of_Line : constant := 50; - - type Line is record - Length : Natural := 0; - Value : String_Access; - Suppressed : Boolean := False; - end record; - -- One line of a Makefile. - -- Length is the position of the last column in the line. - -- Suppressed is set to True by procedure Suppress. - - type Line_Array is array (Positive range <>) of Line; - - type Buffer is access Line_Array; - - procedure Free is new Ada.Unchecked_Deallocation (Line_Array, Buffer); - - Lines : Buffer := new Line_Array (1 .. Initial_Number_Of_Lines); - -- The lines of a Makefile - - Current : Positive := 1; - -- Position of the last line in the Makefile - - File : Text_IO.File_Type; - -- The current Makefile - - type File_Name_Data; - type File_Name_Ref is access File_Name_Data; - - type File_Name_Data is record - Value : String_Access; - Next : File_Name_Ref; - end record; - -- Used to record the names of all Makefiles created, so that we may delete - -- them if necessary. - - File_Names : File_Name_Ref; - -- List of all the Makefiles created so far. - - ----------- - -- Close -- - ----------- - - procedure Close is - begin - Flush; - Text_IO.Close (File); - - exception - when X : others => - Text_IO.Put_Line (Exceptions.Exception_Message (X)); - Osint.Fail ("cannot close a Makefile"); - end Close; - - ------------ - -- Create -- - ------------ - - procedure Create (File_Name : String) is - begin - Text_IO.Create (File, Text_IO.Out_File, File_Name); - Current := 1; - Lines (1).Length := 0; - Lines (1).Suppressed := False; - File_Names := - new File_Name_Data'(Value => new String'(File_Name), - Next => File_Names); - exception - when X : others => - Text_IO.Put_Line (Exceptions.Exception_Message (X)); - Osint.Fail ("cannot create """ & File_Name & '"'); - end Create; - - ---------------- - -- Delete_All -- - ---------------- - - procedure Delete_All is - Success : Boolean; - begin - if Text_IO.Is_Open (File) then - Text_IO.Delete (File); - File_Names := File_Names.Next; - end if; - - while File_Names /= null loop - Delete_File (File_Names.Value.all, Success); - File_Names := File_Names.Next; - end loop; - end Delete_All; - - ----------- - -- Flush -- - ----------- - - procedure Flush is - Last : Natural; - begin - if Lines (Current).Length /= 0 then - Osint.Fail ("INTERNAL ERROR: flushing before end of line: """ & - Lines (Current).Value - (1 .. Lines (Current).Length)); - end if; - - for J in 1 .. Current - 1 loop - if not Lines (J).Suppressed then - Last := Lines (J).Length; - - -- The last character of a line cannot be a back slash ('\'), - -- otherwise make has a problem. The only real place were it - -- should happen is for directory names on Windows, and then - -- this terminal back slash is not needed. - - if Last > 0 and then Lines (J).Value (Last) = '\' then - Last := Last - 1; - end if; - - Text_IO.Put_Line (File, Lines (J).Value (1 .. Last)); - end if; - end loop; - - Current := 1; - Lines (1).Length := 0; - Lines (1).Suppressed := False; - end Flush; - - ---------- - -- Mark -- - ---------- - - procedure Mark (Pos : out Position) is - begin - if Lines (Current).Length /= 0 then - Osint.Fail ("INTERNAL ERROR: marking before end of line: """ & - Lines (Current).Value - (1 .. Lines (Current).Length)); - end if; - - Pos := (Value => Current); - end Mark; - - ------------------ - -- Name_Of_File -- - ------------------ - - function Name_Of_File return String is - begin - return Text_IO.Name (File); - end Name_Of_File; - - -------------- - -- New_Line -- - -------------- - - procedure New_Line is - begin - Current := Current + 1; - - if Current > Lines'Last then - declare - New_Lines : constant Buffer := - new Line_Array (1 .. 2 * Lines'Last); - - begin - New_Lines (1 .. Lines'Last) := Lines.all; - Free (Lines); - Lines := New_Lines; - end; - end if; - - Lines (Current).Length := 0; - Lines (Current).Suppressed := False; - - -- Allocate a new line, if necessary - - if Lines (Current).Value = null then - Lines (Current).Value := new String (1 .. Initial_Length_Of_Line); - end if; - end New_Line; - - --------- - -- Put -- - --------- - - procedure Put (S : String) is - Length : constant Natural := Lines (Current).Length; - - begin - if Length + S'Length > Lines (Current).Value'Length then - declare - New_Line : String_Access; - New_Length : Positive := 2 * Lines (Current).Value'Length; - begin - while Length + S'Length > New_Length loop - New_Length := 2 * New_Length; - end loop; - - New_Line := new String (1 .. New_Length); - New_Line (1 .. Length) := Lines (Current).Value (1 .. Length); - Free (Lines (Current).Value); - Lines (Current).Value := New_Line; - end; - end if; - - Lines (Current).Value (Length + 1 .. Length + S'Length) := S; - Lines (Current).Length := Length + S'Length; - end Put; - - ------------- - -- Release -- - ------------- - - procedure Release (Pos : Position) is - begin - if Lines (Current).Length /= 0 then - Osint.Fail ("INTERNAL ERROR: releasing before end of line: """ & - Lines (Current).Value - (1 .. Lines (Current).Length)); - end if; - - if Pos.Value > Current then - Osint.Fail ("INTERNAL ERROR: releasing ahead of current position"); - end if; - - Current := Pos.Value; - Lines (Current).Length := 0; - end Release; - - -------------- - -- Suppress -- - -------------- - - procedure Suppress (Pos : Position) is - begin - if Pos.Value >= Current then - Osint.Fail ("INTERNAL ERROR: suppressing ahead of current position"); - end if; - - Lines (Pos.Value).Suppressed := True; - end Suppress; - -begin - -- Allocate the first line. - -- The other ones are allocated by New_Line. - - Lines (1).Value := new String (1 .. Initial_Length_Of_Line); -end Bld.IO; |