diff options
Diffstat (limited to 'gcc-4.8/gcc/ada/a-clrefi.adb')
| -rw-r--r-- | gcc-4.8/gcc/ada/a-clrefi.adb | 527 |
1 files changed, 0 insertions, 527 deletions
diff --git a/gcc-4.8/gcc/ada/a-clrefi.adb b/gcc-4.8/gcc/ada/a-clrefi.adb deleted file mode 100644 index 87090258f..000000000 --- a/gcc-4.8/gcc/ada/a-clrefi.adb +++ /dev/null @@ -1,527 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; |