From df62c1c110e8532b995b23540b7e3695729c0779 Mon Sep 17 00:00:00 2001 From: Jing Yu Date: Thu, 5 Nov 2009 15:11:04 -0800 Subject: Check in gcc sources for prebuilt toolchains in Eclair. --- gcc-4.3.1/gcc/ada/a-clrefi.adb | 528 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 528 insertions(+) create mode 100644 gcc-4.3.1/gcc/ada/a-clrefi.adb (limited to 'gcc-4.3.1/gcc/ada/a-clrefi.adb') diff --git a/gcc-4.3.1/gcc/ada/a-clrefi.adb b/gcc-4.3.1/gcc/ada/a-clrefi.adb new file mode 100644 index 000000000..07c0d99c4 --- /dev/null +++ b/gcc-4.3.1/gcc/ada/a-clrefi.adb @@ -0,0 +1,528 @@ +------------------------------------------------------------------------------ +-- -- +-- 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, 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +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; -- cgit v1.2.3