Subversion Repositories openrisc

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT RUN-TIME COMPONENTS                         --
--                                                                          --
--       A D A . C O M M A N D _ L I N E . R E S P O N S E _ F I L E        --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2007-2009, 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.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
pragma Compiler_Unit;
 
with Ada.Unchecked_Deallocation;
 
with System.OS_Lib; use System.OS_Lib;
 
package body Ada.Command_Line.Response_File is
 
   type File_Rec;
   type File_Ptr is access File_Rec;
   type File_Rec is record
      Name : String_Access;
      Next : File_Ptr;
      Prev : File_Ptr;
   end record;
   --  To build a stack of response file names
 
   procedure Free is new Ada.Unchecked_Deallocation (File_Rec, File_Ptr);
 
   type Argument_List_Access is access Argument_List;
   procedure Free is new Ada.Unchecked_Deallocation
     (Argument_List, Argument_List_Access);
   --  Free only the allocated Argument_List, not allocated String components
 
   --------------------
   -- Arguments_From --
   --------------------
 
   function Arguments_From
     (Response_File_Name        : String;
      Recursive                 : Boolean := False;
      Ignore_Non_Existing_Files : Boolean := False)
      return Argument_List
   is
      First_File : File_Ptr := null;
      Last_File  : File_Ptr := null;
      --  The stack of response files
 
      Arguments  : Argument_List_Access := new Argument_List (1 .. 4);
      Last_Arg   : Natural := 0;
 
      procedure Add_Argument (Arg : String);
      --  Add argument Arg to argument list Arguments, increasing Arguments
      --  if necessary.
 
      procedure Recurse (File_Name : String);
      --  Get the arguments from the file and call itself recursively if one of
      --  the argument starts with character '@'.
 
      ------------------
      -- Add_Argument --
      ------------------
 
      procedure Add_Argument (Arg : String) is
      begin
         if Last_Arg = Arguments'Last then
            declare
               New_Arguments : constant Argument_List_Access :=
                                 new Argument_List (1 .. Arguments'Last * 2);
            begin
               New_Arguments (Arguments'Range) := Arguments.all;
               Arguments.all := (others => null);
               Free (Arguments);
               Arguments := New_Arguments;
            end;
         end if;
 
         Last_Arg := Last_Arg + 1;
         Arguments (Last_Arg) := new String'(Arg);
      end Add_Argument;
 
      -------------
      -- Recurse --
      -------------
 
      procedure Recurse (File_Name : String) is
         FD : File_Descriptor;
 
         Buffer_Size : constant := 1500;
         Buffer : String (1 .. Buffer_Size);
 
         Buffer_Length : Natural;
 
         Buffer_Cursor : Natural;
 
         End_Of_File_Reached : Boolean;
 
         Line : String (1 .. Max_Line_Length + 1);
         Last : Natural;
 
         First_Char : Positive;
         --  Index of the first character of an argument in Line
 
         Last_Char : Natural;
         --  Index of the last character of an argument in Line
 
         In_String : Boolean;
         --  True when inside a quoted string
 
         Arg : Positive;
 
         function End_Of_File return Boolean;
         --  True when the end of the response file has been reached
 
         procedure Get_Buffer;
         --  Read one buffer from the response file
 
         procedure Get_Line;
         --  Get one line from the response file
 
         -----------------
         -- End_Of_File --
         -----------------
 
         function End_Of_File return Boolean is
         begin
            return End_Of_File_Reached and then Buffer_Cursor > Buffer_Length;
         end End_Of_File;
 
         ----------------
         -- Get_Buffer --
         ----------------
 
         procedure Get_Buffer is
         begin
            Buffer_Length := Read (FD, Buffer (1)'Address, Buffer'Length);
            End_Of_File_Reached := Buffer_Length < Buffer'Length;
            Buffer_Cursor := 1;
         end Get_Buffer;
 
         --------------
         -- Get_Line --
         --------------
 
         procedure Get_Line is
            Ch : Character;
 
         begin
            Last := 0;
 
            if End_Of_File then
               return;
            end if;
 
            loop
               Ch := Buffer (Buffer_Cursor);
 
               exit when Ch = ASCII.CR or else
                         Ch = ASCII.LF or else
                         Ch = ASCII.FF;
 
               Last := Last + 1;
               Line (Last) := Ch;
 
               if Last = Line'Last then
                  return;
               end if;
 
               Buffer_Cursor := Buffer_Cursor + 1;
 
               if Buffer_Cursor > Buffer_Length then
                  Get_Buffer;
 
                  if End_Of_File then
                     return;
                  end if;
               end if;
            end loop;
 
            loop
               Ch := Buffer (Buffer_Cursor);
 
               exit when Ch /= ASCII.HT and then
                         Ch /= ASCII.LF and then
                         Ch /= ASCII.FF;
 
               Buffer_Cursor := Buffer_Cursor + 1;
 
               if Buffer_Cursor > Buffer_Length then
                  Get_Buffer;
 
                  if End_Of_File then
                     return;
                  end if;
               end if;
            end loop;
         end Get_Line;
 
      --  Start or Recurse
 
      begin
         Last_Arg := 0;
 
         --  Open the response file. If not found, fail or report a warning,
         --  depending on the value of Ignore_Non_Existing_Files.
 
         FD := Open_Read (File_Name, Text);
 
         if FD = Invalid_FD then
            if Ignore_Non_Existing_Files then
               return;
            else
               raise File_Does_Not_Exist;
            end if;
         end if;
 
         --  Put the response file name on the stack
 
         if First_File = null then
            First_File :=
              new File_Rec'
                (Name => new String'(File_Name),
                 Next => null,
                 Prev => null);
            Last_File  := First_File;
 
         else
            declare
               Current : File_Ptr := First_File;
 
            begin
               loop
                  if Current.Name.all = File_Name then
                     raise Circularity_Detected;
                  end if;
 
                  Current := Current.Next;
                  exit when Current = null;
               end loop;
 
               Last_File.Next :=
                 new File_Rec'
                   (Name => new String'(File_Name),
                    Next => null,
                    Prev => Last_File);
               Last_File := Last_File.Next;
            end;
         end if;
 
         End_Of_File_Reached := False;
         Get_Buffer;
 
         --  Read the response file line by line
 
         Line_Loop :
         while not End_Of_File loop
            Get_Line;
 
            if Last = Line'Last then
               raise Line_Too_Long;
            end if;
 
            First_Char := 1;
 
            --  Get each argument on the line
 
            Arg_Loop :
            loop
               --  First, skip any white space
 
               while First_Char <= Last loop
                  exit when Line (First_Char) /= ' ' and then
                            Line (First_Char) /= ASCII.HT;
                  First_Char := First_Char + 1;
               end loop;
 
               exit Arg_Loop when First_Char > Last;
 
               Last_Char := First_Char;
               In_String := False;
 
               --  Get the character one by one
 
               Character_Loop :
               while Last_Char <= Last loop
 
                  --  Inside a string, check only for '"'
 
                  if In_String then
                     if Line (Last_Char) = '"' then
 
                        --  Remove the '"'
 
                        Line (Last_Char .. Last - 1) :=
                          Line (Last_Char + 1 .. Last);
                        Last := Last - 1;
 
                        --  End of string is end of argument
 
                        if Last_Char > Last or else
                          Line (Last_Char) = ' ' or else
                          Line (Last_Char) = ASCII.HT
                        then
                           In_String := False;
 
                           Last_Char := Last_Char - 1;
                           exit Character_Loop;
 
                        else
                           --  If there are two consecutive '"', the quoted
                           --  string is not closed
 
                           In_String := Line (Last_Char) = '"';
 
                           if In_String then
                              Last_Char := Last_Char + 1;
                           end if;
                        end if;
 
                     else
                        Last_Char := Last_Char + 1;
                     end if;
 
                  elsif Last_Char = Last then
 
                     --  An opening '"' at the end of the line is an error
 
                     if Line (Last) = '"' then
                        raise No_Closing_Quote;
 
                     else
                        --  The argument ends with the line
 
                        exit Character_Loop;
                     end if;
 
                  elsif Line (Last_Char) = '"' then
 
                     --  Entering a quoted string: remove the '"'
 
                     In_String := True;
                     Line (Last_Char .. Last - 1) :=
                       Line (Last_Char + 1 .. Last);
                     Last := Last - 1;
 
                  else
                     --  Outside quoted strings, white space ends the argument
 
                     exit Character_Loop
                          when Line (Last_Char + 1) = ' ' or else
                               Line (Last_Char + 1) = ASCII.HT;
 
                     Last_Char := Last_Char + 1;
                  end if;
               end loop Character_Loop;
 
               --  It is an error to not close a quoted string before the end
               --  of the line.
 
               if In_String then
                  raise No_Closing_Quote;
               end if;
 
               --  Add the argument to the list
 
               declare
                  Arg : String (1 .. Last_Char - First_Char + 1);
               begin
                  Arg := Line (First_Char .. Last_Char);
                  Add_Argument (Arg);
               end;
 
               --  Next argument, if line is not finished
 
               First_Char := Last_Char + 1;
            end loop Arg_Loop;
         end loop Line_Loop;
 
         Close (FD);
 
         --  If Recursive is True, check for any argument starting with '@'
 
         if Recursive then
            Arg := 1;
            while Arg <= Last_Arg loop
 
               if Arguments (Arg)'Length > 0 and then
                  Arguments (Arg) (1) = '@'
               then
                  --  Ignore argument "@" with no file name
 
                  if Arguments (Arg)'Length = 1 then
                     Arguments (Arg .. Last_Arg - 1) :=
                       Arguments (Arg + 1 .. Last_Arg);
                     Last_Arg := Last_Arg - 1;
 
                  else
                     --  Save the current arguments and get those in the new
                     --  response file.
 
                     declare
                        Inc_File_Name     : constant String :=
                                              Arguments (Arg)
                                              (2 .. Arguments (Arg)'Last);
                        Current_Arguments : constant Argument_List :=
                                              Arguments (1 .. Last_Arg);
                     begin
                        Recurse (Inc_File_Name);
 
                        --  Insert the new arguments where the new response
                        --  file was imported.
 
                        declare
                           New_Arguments : constant Argument_List :=
                                             Arguments (1 .. Last_Arg);
                           New_Last_Arg  : constant Positive :=
                                             Current_Arguments'Length +
                                             New_Arguments'Length - 1;
 
                        begin
                           --  Grow Arguments if it is not large enough
 
                           if Arguments'Last < New_Last_Arg then
                              Last_Arg := Arguments'Last;
                              Free (Arguments);
 
                              while Last_Arg < New_Last_Arg loop
                                 Last_Arg := Last_Arg * 2;
                              end loop;
 
                              Arguments := new Argument_List (1 .. Last_Arg);
                           end if;
 
                           Last_Arg := New_Last_Arg;
 
                           Arguments (1 .. Last_Arg) :=
                             Current_Arguments (1 .. Arg - 1) &
                           New_Arguments &
                           Current_Arguments
                             (Arg + 1 .. Current_Arguments'Last);
 
                           Arg := Arg + New_Arguments'Length;
                        end;
                     end;
                  end if;
 
               else
                  Arg := Arg + 1;
               end if;
            end loop;
         end if;
 
         --  Remove the response file name from the stack
 
         if First_File = Last_File then
            System.Strings.Free (First_File.Name);
            Free (First_File);
            First_File := null;
            Last_File := null;
 
         else
            System.Strings.Free (Last_File.Name);
            Last_File := Last_File.Prev;
            Free (Last_File.Next);
         end if;
 
      exception
         when others =>
            Close (FD);
 
            raise;
      end Recurse;
 
   --  Start of Arguments_From
 
   begin
      --  The job is done by procedure Recurse
 
      Recurse (Response_File_Name);
 
      --  Free Arguments before returning the result
 
      declare
         Result : constant Argument_List := Arguments (1 .. Last_Arg);
      begin
         Free (Arguments);
         return Result;
      end;
 
   exception
      when others =>
 
         --  When an exception occurs, deallocate everything
 
         Free (Arguments);
 
         while First_File /= null loop
            Last_File := First_File.Next;
            System.Strings.Free (First_File.Name);
            Free (First_File);
            First_File := Last_File;
         end loop;
 
         raise;
   end Arguments_From;
 
end Ada.Command_Line.Response_File;