| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |
