aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.3.1/gcc/ada/a-clrefi.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.3.1/gcc/ada/a-clrefi.adb')
-rw-r--r--gcc-4.3.1/gcc/ada/a-clrefi.adb528
1 files changed, 528 insertions, 0 deletions
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;