+2017-09-06 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch5.adb, s-diinio.ads, sem_ch4.adb, s-diflio.ads: Minor spelling
+ adjustments and a typo fix.
+
+2017-09-06 Yannick Moy <moy@adacore.com>
+
+ * sem_res.adb (Resolve_Call): Do not issue info
+ message about inlining of calls to functions in assertions,
+ for functions whose body has not been seen yet.
+
+2017-09-06 Bob Duff <duff@adacore.com>
+
+ * a-comlin.ads, a-comlin.adb (Argument): Simplify the code, now that
+ we can use modern Ada in this package.
+ * s-resfil.ads, s-resfil.adb, a-clrefi.ads, a-clrefi.adb:
+ Move Ada.Command_Line.Response_File to System.Response_File,
+ and make Ada.Command_Line.Response_File into a rename of
+ System.Response_File. This is to avoid having gnatbind depend
+ Ada.Command_Line, which would damage the bootstrap process now
+ that Ada.Command_Line contains modern Ada (the raise expression).
+ * gnatbind.adb: Avoid dependence on
+ Ada.Command_Line. Depend on System.Response_File instead
+ of Ada.Command_Line.Response_File. Change one call to
+ Ada.Command_Line.Command_Name to use Fill_Arg. Change one call
+ to Ada.Command_Line.Argument_Count to use Arg_Count.
+ * gcc-interface/Make-lang.in, Makefile.rtl: Take note of the new files.
+
2017-09-06 Bob Duff <duff@adacore.com>
* frontend.adb (Frontend): Skip -gnatec=gnat.adc
# Makefile.rtl for GNU Ada Compiler (GNAT).
-# Copyright (C) 2003-2012, Free Software Foundation, Inc.
+# Copyright (C) 2003-2017, Free Software Foundation, Inc.
#This file is part of GCC.
s-ransee$(objext) \
s-regexp$(objext) \
s-regpat$(objext) \
+ s-resfil$(objext) \
s-restri$(objext) \
s-rident$(objext) \
s-rpc$(objext) \
-- --
------------------------------------------------------------------------------
-pragma Compiler_Unit_Warning;
+-- This package does not require a body, since it is a package renaming. We
+-- provide a dummy file containing a No_Body pragma so that previous versions
+-- of the body (which did exist) will not interfere.
-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
- -- Open the response file. If not found, fail or report a warning,
- -- depending on the value of Ignore_Non_Existing_Files.
-
- FD : constant File_Descriptor := Open_Read (File_Name, Text);
-
- 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 of processing for Recurse
-
- begin
- Last_Arg := 0;
-
- 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 processing for 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;
+pragma No_Body;
-- --
-- S p e c --
-- --
--- Copyright (C) 2007-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2007-2017, 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- --
-- --
------------------------------------------------------------------------------
--- This package is intended to be used in conjunction with its parent unit,
--- Ada.Command_Line. It provides facilities for getting command line arguments
--- from a text file, called a "response file".
---
--- Using a response file allow passing a set of arguments to an executable
--- longer than the maximum allowed by the system on the command line.
+-- See s-resfil.ads for documentation
-pragma Compiler_Unit_Warning;
-
-with System.Strings;
-
-package Ada.Command_Line.Response_File is
-
- subtype String_Access is System.Strings.String_Access;
- -- type String_Access is access all String;
-
- procedure Free (S : in out String_Access) renames System.Strings.Free;
- -- To deallocate a String
-
- subtype Argument_List is System.Strings.String_List;
- -- type String_List is array (Positive range <>) of String_Access;
-
- Max_Line_Length : constant := 4096;
- -- The maximum length of lines in a response file
-
- File_Does_Not_Exist : exception;
- -- Raise by Arguments_From when a response file cannot be found
-
- Line_Too_Long : exception;
- -- Raise by Arguments_From when a line in the response file is longer than
- -- Max_Line_Length.
-
- No_Closing_Quote : exception;
- -- Raise by Arguments_From when a quoted string does not end before the
- -- end of the line.
-
- Circularity_Detected : exception;
- -- Raise by Arguments_From when Recursive is True and the same response
- -- file is reading itself, either directly or indirectly.
-
- function Arguments_From
- (Response_File_Name : String;
- Recursive : Boolean := False;
- Ignore_Non_Existing_Files : Boolean := False)
- return Argument_List;
- -- Read response file with name Response_File_Name and return the argument
- -- it contains as an Argument_List. It is the responsibility of the caller
- -- to deallocate the strings in the Argument_List if desired. When
- -- Recursive is True, any argument of the form @file_name indicates the
- -- name of another response file and is replaced by the arguments in this
- -- response file.
- --
- -- Each non empty line of the response file contains one or several
- -- arguments separated by white space. Empty lines or lines containing only
- -- white space are ignored. Arguments containing white space or a double
- -- quote ('"')must be quoted. A double quote inside a quote string is
- -- indicated by two consecutive double quotes. Example: "-Idir with quote
- -- "" and spaces" Non white space characters immediately before or after a
- -- quoted string are part of the same argument. Example -Idir" with "spaces
- --
- -- When a response file cannot be found, exception File_Does_Not_Exist is
- -- raised if Ignore_Non_Existing_Files is False, otherwise the response
- -- file is ignored. Exception Line_Too_Long is raised when a line of a
- -- response file is longer than Max_Line_Length. Exception No_Closing_Quote
- -- is raised when a quoted argument is not closed before the end of the
- -- line. Exception Circularity_Detected is raised when a Recursive is True
- -- and a response file is reading itself, either directly or indirectly.
-
-end Ada.Command_Line.Response_File;
+with System.Response_File;
+package Ada.Command_Line.Response_File renames System.Response_File;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
-- --
------------------------------------------------------------------------------
-pragma Compiler_Unit_Warning;
-
with System; use System;
package body Ada.Command_Line is
--------------
function Argument (Number : Positive) return String is
- Num : Positive;
-
+ Num : constant Positive :=
+ (if Remove_Args = null then Number else Remove_Args (Number));
+ Arg : aliased String (1 .. Len_Arg (Num));
begin
- if Number > Argument_Count then
- raise Constraint_Error;
- end if;
-
- if Remove_Args = null then
- Num := Number;
- else
- Num := Remove_Args (Number);
- end if;
-
- declare
- Arg : aliased String (1 .. Len_Arg (Num));
- begin
- Fill_Arg (Arg'Address, Num);
- return Arg;
- end;
+ Fill_Arg (Arg'Address, Num);
+ return Arg;
end Argument;
--------------------
-- --
------------------------------------------------------------------------------
-pragma Compiler_Unit_Warning;
-
package Ada.Command_Line is
pragma Preelaborate;
--
-- In GNAT: Corresponds to (argc - 1) in C.
- pragma Assertion_Policy (Pre => Ignore);
- -- We need to ignore the precondition of Argument, below, so that we don't
- -- raise Assertion_Error. The body raises Constraint_Error. It would be
- -- cleaner to add "or else raise Constraint_Error" to the precondition, but
- -- SPARK does not yet support raise expressions.
-
- function Argument (Number : Positive) return String;
- pragma Precondition (Number <= Argument_Count);
+ function Argument (Number : Positive) return String with
+ Pre => Number <= Argument_Count or else raise Constraint_Error;
-- If the external execution environment supports passing arguments to
-- a program, then Argument returns an implementation-defined value
-- corresponding to the argument at relative position Number. If Number
-- redefined on derived container types, while the default
-- iterator was inherited from the parent type. This
-- nonstandard extension is preserved for use by the
- -- modelling project under debug flag -gnatd.X.
+ -- modeling project under debug flag -gnatd.X.
if Debug_Flag_Dot_XX then
if Base_Type (Etype (Container)) /=
GNAT1_OBJS = $(GNAT1_C_OBJS) $(GNAT1_ADA_OBJS) ada/b_gnat1.o
GNATBIND_OBJS = \
- ada/a-clrefi.o \
- ada/a-comlin.o \
ada/a-elchha.o \
ada/a-except.o \
ada/ada.o \
ada/s-memory.o \
ada/s-os_lib.o \
ada/s-parame.o \
+ ada/s-resfil.o \
ada/s-restri.o \
ada/s-secsta.o \
ada/s-soflin.o \
with Fmap;
with Namet; use Namet;
with Opt; use Opt;
+
with Osint; use Osint;
+-- Note that we use low-level routines in Osint to read command-line
+-- arguments. We cannot depend on Ada.Command_Line, because it contains modern
+-- Ada features that would break bootstrapping with old base compilers.
+
with Osint.B; use Osint.B;
with Output; use Output;
with Rident; use Rident;
with Types; use Types;
with System.Case_Util; use System.Case_Util;
+with System.Response_File;
with System.OS_Lib; use System.OS_Lib;
-with Ada.Command_Line.Response_File; use Ada.Command_Line;
-
procedure Gnatbind is
Total_Errors : Nat := 0;
Next_Arg : Positive := 1;
begin
- -- Use low level argument routines to avoid dragging in secondary stack
-
while Next_Arg < Arg_Count loop
declare
Next_Argv : String (1 .. Len_Arg (Next_Arg));
if Next_Argv'Length > 1 then
declare
Arguments : constant Argument_List :=
- Response_File.Arguments_From
+ System.Response_File.Arguments_From
(Response_File_Name =>
Next_Argv (2 .. Next_Argv'Last),
Recursive => True,
Scan_Bind_Args;
if Verbose_Mode then
- Write_Str (Command_Name);
+ declare
+ Command_Name : String (1 .. Len_Arg (0));
+ begin
+ Fill_Arg (Command_Name'Address, 0);
+ Write_Str (Command_Name);
+ end;
+
Put_Bind_Args;
Write_Eol;
end if;
-- Output usage information if no arguments
if not More_Lib_Files then
- if Argument_Count = 0 then
+ if Arg_Count = 0 then
Bindusg.Display;
else
Write_Line ("try ""gnatbind --help"" for more information.");
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2017, 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- --
------------------------------------------------------------------------------
-- This package provides output routines for float dimensioned types. All Put
--- routines are modelled after those in package Ada.Text_IO.Float_IO with the
+-- routines are modeled after those in package Ada.Text_IO.Float_IO with the
-- addition of an extra default parameter. All Put_Dim_Of routines
-- output the dimension of Item in a symbolic manner.
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2017, 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- --
------------------------------------------------------------------------------
-- This package provides output routines for integer dimensioned types. All
--- Put routines are modelled after those in package Ada.Text_IO.Integer_IO
+-- Put routines are modeled after those in package Ada.Text_IO.Integer_IO
-- with the addition of an extra default parameter. All Put_Dim_Of routines
-- output the dimension of Item in a symbolic manner.
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . R E S P O N S E _ F I L E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2017, 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_Warning;
+
+with Ada.Unchecked_Deallocation;
+
+with System.OS_Lib; use System.OS_Lib;
+
+package body System.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 arguments 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
+ -- Open the response file. If not found, fail or report a warning,
+ -- depending on the value of Ignore_Non_Existing_Files.
+
+ FD : constant File_Descriptor := Open_Read (File_Name, Text);
+
+ 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 of processing for Recurse
+
+ begin
+ Last_Arg := 0;
+
+ 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 processing for 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 System.Response_File;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . R E S P O N S E _ F I L E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-2017, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides facilities for getting command line arguments
+-- from a text file, called a "response file".
+--
+-- Using a response file allow passing a set of arguments to an executable
+-- longer than the maximum allowed by the system on the command line.
+
+pragma Compiler_Unit_Warning;
+
+with System.Strings;
+
+package System.Response_File is
+
+ subtype String_Access is System.Strings.String_Access;
+ -- type String_Access is access all String;
+
+ procedure Free (S : in out String_Access) renames System.Strings.Free;
+ -- To deallocate a String
+
+ subtype Argument_List is System.Strings.String_List;
+ -- type String_List is array (Positive range <>) of String_Access;
+
+ Max_Line_Length : constant := 4096;
+ -- The maximum length of lines in a response file
+
+ File_Does_Not_Exist : exception;
+ -- Raise by Arguments_From when a response file cannot be found
+
+ Line_Too_Long : exception;
+ -- Raise by Arguments_From when a line in the response file is longer than
+ -- Max_Line_Length.
+
+ No_Closing_Quote : exception;
+ -- Raise by Arguments_From when a quoted string does not end before the
+ -- end of the line.
+
+ Circularity_Detected : exception;
+ -- Raise by Arguments_From when Recursive is True and the same response
+ -- file is reading itself, either directly or indirectly.
+
+ function Arguments_From
+ (Response_File_Name : String;
+ Recursive : Boolean := False;
+ Ignore_Non_Existing_Files : Boolean := False)
+ return Argument_List;
+ -- Read response file with name Response_File_Name and return the argument
+ -- it contains as an Argument_List. It is the responsibility of the caller
+ -- to deallocate the strings in the Argument_List if desired. When
+ -- Recursive is True, any argument of the form @file_name indicates the
+ -- name of another response file and is replaced by the arguments in this
+ -- response file.
+ --
+ -- Each nonempty line of the response file contains one or several
+ -- arguments separated by white space. Empty lines or lines containing only
+ -- white space are ignored. Arguments containing white space or a double
+ -- quote ('"')must be quoted. A double quote inside a quote string is
+ -- indicated by two consecutive double quotes. Example: "-Idir with quote
+ -- "" and spaces". Non-white-space characters immediately before or after a
+ -- quoted string are part of the same argument. Ex: -Idir" with "spaces
+ --
+ -- When a response file cannot be found, exception File_Does_Not_Exist is
+ -- raised if Ignore_Non_Existing_Files is False, otherwise the response
+ -- file is ignored. Exception Line_Too_Long is raised when a line of a
+ -- response file is longer than Max_Line_Length. Exception No_Closing_Quote
+ -- is raised when a quoted argument is not closed before the end of the
+ -- line. Exception Circularity_Detected is raised when a Recursive is True
+ -- and a response file is reading itself, either directly or indirectly.
+
+end System.Response_File;
-- Called when P is the prefix of an implicit dereference, denoting an
-- object E. The function returns the designated type of the prefix, taking
-- into account that the designated type of an anonymous access type may be
- -- a limited view, when the non-limited view is visible.
+ -- a limited view, when the nonlimited view is visible.
--
-- If in semantics only mode (-gnatc or generic), the function also records
-- that the prefix is a reference to E, if any. Normally, such a reference
("\constraint with discriminant values required", N);
end if;
- -- Limited Ada 2005 and general non-limited case
+ -- Limited Ada 2005 and general nonlimited case
else
Error_Msg_N
-- can also happen when the function declaration appears before the
-- full view of the type (which is legal in Ada 2012) and the call
-- appears in a different unit, in which case the incomplete view
- -- must be replaced with the full view (or the non-limited view)
+ -- must be replaced with the full view (or the nonlimited view)
-- to prevent subsequent type errors. Note that the usual install/
-- removal of limited_with clauses is not sufficient to handle this
- -- case, because the limited view may have been captured is another
+ -- case, because the limited view may have been captured in another
-- compilation unit that defines the current function.
if Is_Incomplete_Type (Etype (N)) then
-- in what follows, either to retrieve a component of to find
-- a primitive operation. If the prefix is an explicit dereference,
-- set the type of the prefix to reflect this transformation.
- -- If the non-limited view is itself an incomplete type, get the
+ -- If the nonlimited view is itself an incomplete type, get the
-- full view if available.
if From_Limited_With (Prefix_Type)
-- The type may have be obtained through a limited_with clause,
-- in which case the primitive operations are available on its
- -- non-limited view. If still incomplete, retrieve full view.
+ -- nonlimited view. If still incomplete, retrieve full view.
if Ekind (Obj_Type) = E_Incomplete_Type
and then From_Limited_With (Obj_Type)
null;
-- Calls cannot be inlined inside assertions, as GNATprove treats
- -- assertions as logic expressions.
+ -- assertions as logic expressions. Only issue a message when the
+ -- body has been seen, otherwise this leads to spurious messages
+ -- on expression functions.
elsif In_Assertion_Expr /= 0 then
- Cannot_Inline
- ("cannot inline & (in assertion expression)?", N, Nam_UA);
+ if Present (Body_Id) then
+ Cannot_Inline
+ ("cannot inline & (in assertion expression)?", N, Nam_UA);
+ end if;
-- Calls cannot be inlined inside default expressions
projects / gcc.git / commitdiff