URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc1/] [gcc/] [ada/] [a-clrefi.adb] - Rev 338
Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- 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;