gcc/ada/bld-io.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                               B L D - I O                                --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --        Copyright (C) 2002-2003 Free Software Foundation, Inc.            --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Ada.Exceptions;
  28 with Ada.Text_IO;
  29 with Ada.Unchecked_Deallocation;
  30
  31 with GNAT.OS_Lib; use GNAT.OS_Lib;
  32 with Osint;
  33
  34 package body Bld.IO is
  35
  36    use Ada;
  37
  38    Initial_Number_Of_Lines : constant := 100;
  39    Initial_Length_Of_Line  : constant := 50;
  40
  41    type Line is record
  42       Length     : Natural := 0;
  43       Value      : String_Access;
  44       Suppressed : Boolean := False;
  45    end record;
  46    --  One line of a Makefile.
  47    --  Length is the position of the last column in the line.
  48    --  Suppressed is set to True by procedure Suppress.
  49
  50    type Line_Array is array (Positive range <>) of Line;
  51
  52    type Buffer is access Line_Array;
  53
  54    procedure Free is new Ada.Unchecked_Deallocation (Line_Array, Buffer);
  55
  56    Lines : Buffer := new Line_Array (1 .. Initial_Number_Of_Lines);
  57    --  The lines of a Makefile
  58
  59    Current : Positive := 1;
  60    --  Position of the last line in the Makefile
  61
  62    File : Text_IO.File_Type;
  63    --  The current Makefile
  64
  65    type File_Name_Data;
  66    type File_Name_Ref is access File_Name_Data;
  67
  68    type File_Name_Data is record
  69       Value : String_Access;
  70       Next : File_Name_Ref;
  71    end record;
  72    --  Used to record the names of all Makefiles created, so that we may delete
  73    --  them if necessary.
  74
  75    File_Names : File_Name_Ref;
  76    --  List of all the Makefiles created so far.
  77
  78    -----------
  79    -- Close --
  80    -----------
  81
  82    procedure Close is
  83    begin
  84       Flush;
  85       Text_IO.Close (File);
  86
  87    exception
  88       when X : others =>
  89          Text_IO.Put_Line (Exceptions.Exception_Message (X));
  90          Osint.Fail ("cannot close a Makefile");
  91    end Close;
  92
  93    ------------
  94    -- Create --
  95    ------------
  96
  97    procedure Create (File_Name : String) is
  98    begin
  99       Text_IO.Create (File, Text_IO.Out_File, File_Name);
 100       Current := 1;
 101       Lines (1).Length := 0;
 102       Lines (1).Suppressed := False;
 103       File_Names :=
 104         new File_Name_Data'(Value => new String'(File_Name),
 105                             Next  => File_Names);
 106    exception
 107       when X : others =>
 108          Text_IO.Put_Line (Exceptions.Exception_Message (X));
 109          Osint.Fail ("cannot create """ & File_Name & '"');
 110    end Create;
 111
 112    ----------------
 113    -- Delete_All --
 114    ----------------
 115
 116    procedure Delete_All is
 117       Success : Boolean;
 118    begin
 119       if Text_IO.Is_Open (File) then
 120          Text_IO.Delete (File);
 121          File_Names := File_Names.Next;
 122       end if;
 123
 124       while File_Names /= null loop
 125          Delete_File (File_Names.Value.all, Success);
 126          File_Names := File_Names.Next;
 127       end loop;
 128    end Delete_All;
 129
 130    -----------
 131    -- Flush --
 132    -----------
 133
 134    procedure Flush is
 135       Last : Natural;
 136    begin
 137       if Lines (Current).Length /= 0 then
 138          Osint.Fail ("INTERNAL ERROR: flushing before end of line: """ &
 139                  Lines (Current).Value
 140                    (1 .. Lines (Current).Length));
 141       end if;
 142
 143       for J in 1 .. Current - 1 loop
 144          if not Lines (J).Suppressed then
 145             Last := Lines (J).Length;
 146
 147             --  The last character of a line cannot be a back slash ('\'),
 148             --  otherwise make has a problem. The only real place were it
 149             --  should happen is for directory names on Windows, and then
 150             --  this terminal back slash is not needed.
 151
 152             if Last > 0 and then Lines (J).Value (Last) = '\' then
 153                Last := Last - 1;
 154             end if;
 155
 156             Text_IO.Put_Line (File, Lines (J).Value (1 .. Last));
 157          end if;
 158       end loop;
 159
 160       Current := 1;
 161       Lines (1).Length := 0;
 162       Lines (1).Suppressed := False;
 163    end Flush;
 164
 165    ----------
 166    -- Mark --
 167    ----------
 168
 169    procedure Mark (Pos : out Position) is
 170    begin
 171       if Lines (Current).Length /= 0 then
 172          Osint.Fail ("INTERNAL ERROR: marking before end of line: """ &
 173                  Lines (Current).Value
 174                    (1 .. Lines (Current).Length));
 175       end if;
 176
 177       Pos := (Value => Current);
 178    end Mark;
 179
 180    ------------------
 181    -- Name_Of_File --
 182    ------------------
 183
 184    function Name_Of_File return String is
 185    begin
 186       return Text_IO.Name (File);
 187    end Name_Of_File;
 188
 189    --------------
 190    -- New_Line --
 191    --------------
 192
 193    procedure New_Line is
 194    begin
 195       Current := Current + 1;
 196
 197       if Current > Lines'Last then
 198          declare
 199             New_Lines : constant Buffer :=
 200                           new Line_Array (1 .. 2 * Lines'Last);
 201
 202          begin
 203             New_Lines (1 .. Lines'Last) := Lines.all;
 204             Free (Lines);
 205             Lines := New_Lines;
 206          end;
 207       end if;
 208
 209       Lines (Current).Length := 0;
 210       Lines (Current).Suppressed := False;
 211
 212       --  Allocate a new line, if necessary
 213
 214       if Lines (Current).Value = null then
 215          Lines (Current).Value := new String (1 .. Initial_Length_Of_Line);
 216       end if;
 217    end New_Line;
 218
 219    ---------
 220    -- Put --
 221    ---------
 222
 223    procedure Put (S : String) is
 224       Length : constant Natural := Lines (Current).Length;
 225
 226    begin
 227       if Length + S'Length > Lines (Current).Value'Length then
 228          declare
 229             New_Line   : String_Access;
 230             New_Length : Positive := 2 * Lines (Current).Value'Length;
 231          begin
 232             while Length + S'Length > New_Length loop
 233                New_Length := 2 * New_Length;
 234             end loop;
 235
 236             New_Line := new String (1 .. New_Length);
 237             New_Line (1 .. Length) := Lines (Current).Value (1 .. Length);
 238             Free (Lines (Current).Value);
 239             Lines (Current).Value := New_Line;
 240          end;
 241       end if;
 242
 243       Lines (Current).Value (Length + 1 .. Length + S'Length) := S;
 244       Lines (Current).Length := Length + S'Length;
 245    end Put;
 246
 247    -------------
 248    -- Release --
 249    -------------
 250
 251    procedure Release (Pos : Position) is
 252    begin
 253       if Lines (Current).Length /= 0 then
 254          Osint.Fail ("INTERNAL ERROR: releasing before end of line: """ &
 255                  Lines (Current).Value
 256                    (1 .. Lines (Current).Length));
 257       end if;
 258
 259       if Pos.Value > Current then
 260          Osint.Fail ("INTERNAL ERROR: releasing ahead of current position");
 261       end if;
 262
 263       Current := Pos.Value;
 264       Lines (Current).Length := 0;
 265    end Release;
 266
 267    --------------
 268    -- Suppress --
 269    --------------
 270
 271    procedure Suppress (Pos : Position) is
 272    begin
 273       if Pos.Value >= Current then
 274          Osint.Fail ("INTERNAL ERROR: suppressing ahead of current position");
 275       end if;
 276
 277       Lines (Pos.Value).Suppressed := True;
 278    end Suppress;
 279
 280 begin
 281    --  Allocate the first line.
 282    --  The other ones are allocated by New_Line.
 283
 284    Lines (1).Value := new String (1 .. Initial_Length_Of_Line);
 285 end Bld.IO;