path: root/gcc/ada/a-clrefi.adb

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