Skip to content

R
riscv-gcc-1
Commit a316b3fc by Arnaud Charlet
Options

[multiple changes] 

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.

From-SVN: r251775
parent 9caf55e3
Showing with 704 additions and 617 deletions
gcc/ada/ChangeLog
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> 2017-09-06 Bob Duff <duff@adacore.com>
* frontend.adb (Frontend): Skip -gnatec=gnat.adc * frontend.adb (Frontend): Skip -gnatec=gnat.adc
......
gcc/ada/Makefile.rtl
# Makefile.rtl for GNU Ada Compiler (GNAT). # 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. #This file is part of GCC.
...@@ -651,6 +651,7 @@ GNATRTL_NONTASKING_OBJS= \ ...@@ -651,6 +651,7 @@ GNATRTL_NONTASKING_OBJS= \
s-ransee$(objext) \ s-ransee$(objext) \
s-regexp$(objext) \ s-regexp$(objext) \
s-regpat$(objext) \ s-regpat$(objext) \
s-resfil$(objext) \
s-restri$(objext) \ s-restri$(objext) \
s-rident$(objext) \ s-rident$(objext) \
s-rpc$(objext) \ s-rpc$(objext) \
......
gcc/ada/a-clrefi.adb
...@@ -29,497 +29,8 @@ ...@@ -29,497 +29,8 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
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; pragma No_Body;
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;
gcc/ada/a-clrefi.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -29,72 +29,7 @@ ...@@ -29,72 +29,7 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This package is intended to be used in conjunction with its parent unit, -- See s-resfil.ads for documentation
-- 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.
pragma Compiler_Unit_Warning; with System.Response_File;
package Ada.Command_Line.Response_File renames System.Response_File;
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;
gcc/ada/a-comlin.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -29,8 +29,6 @@ ...@@ -29,8 +29,6 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
pragma Compiler_Unit_Warning;
with System; use System; with System; use System;
package body Ada.Command_Line is package body Ada.Command_Line is
...@@ -58,25 +56,12 @@ package body Ada.Command_Line is ...@@ -58,25 +56,12 @@ package body Ada.Command_Line is
-------------- --------------
function Argument (Number : Positive) return String 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 begin
if Number > Argument_Count then Fill_Arg (Arg'Address, Num);
raise Constraint_Error; return Arg;
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;
end Argument; end Argument;
-------------------- --------------------
......
gcc/ada/a-comlin.ads
...@@ -33,8 +33,6 @@ ...@@ -33,8 +33,6 @@
-- -- -- --
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
pragma Compiler_Unit_Warning;
package Ada.Command_Line is package Ada.Command_Line is
pragma Preelaborate; pragma Preelaborate;
...@@ -45,14 +43,8 @@ package Ada.Command_Line is ...@@ -45,14 +43,8 @@ package Ada.Command_Line is
-- --
-- In GNAT: Corresponds to (argc - 1) in C. -- In GNAT: Corresponds to (argc - 1) in C.
pragma Assertion_Policy (Pre => Ignore); function Argument (Number : Positive) return String with
-- We need to ignore the precondition of Argument, below, so that we don't Pre => Number <= Argument_Count or else raise Constraint_Error;
-- 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);
-- If the external execution environment supports passing arguments to -- If the external execution environment supports passing arguments to
-- a program, then Argument returns an implementation-defined value -- a program, then Argument returns an implementation-defined value
-- corresponding to the argument at relative position Number. If Number -- corresponding to the argument at relative position Number. If Number
......
gcc/ada/exp_ch5.adb
...@@ -3957,7 +3957,7 @@ package body Exp_Ch5 is ...@@ -3957,7 +3957,7 @@ package body Exp_Ch5 is
-- redefined on derived container types, while the default -- redefined on derived container types, while the default
-- iterator was inherited from the parent type. This -- iterator was inherited from the parent type. This
-- nonstandard extension is preserved for use by the -- 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 Debug_Flag_Dot_XX then
if Base_Type (Etype (Container)) /= if Base_Type (Etype (Container)) /=
......
gcc/ada/gcc-interface/Make-lang.in
...@@ -468,8 +468,6 @@ GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) ada/back_end.o ada/gnat1drv.o ...@@ -468,8 +468,6 @@ GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) ada/back_end.o ada/gnat1drv.o
GNAT1_OBJS = $(GNAT1_C_OBJS) $(GNAT1_ADA_OBJS) ada/b_gnat1.o GNAT1_OBJS = $(GNAT1_C_OBJS) $(GNAT1_ADA_OBJS) ada/b_gnat1.o
GNATBIND_OBJS = \ GNATBIND_OBJS = \
ada/a-clrefi.o \
ada/a-comlin.o \
ada/a-elchha.o \ ada/a-elchha.o \
ada/a-except.o \ ada/a-except.o \
ada/ada.o \ ada/ada.o \
...@@ -553,6 +551,7 @@ GNATBIND_OBJS = \ ...@@ -553,6 +551,7 @@ GNATBIND_OBJS = \
ada/s-memory.o \ ada/s-memory.o \
ada/s-os_lib.o \ ada/s-os_lib.o \
ada/s-parame.o \ ada/s-parame.o \
ada/s-resfil.o \
ada/s-restri.o \ ada/s-restri.o \
ada/s-secsta.o \ ada/s-secsta.o \
ada/s-soflin.o \ ada/s-soflin.o \
......
gcc/ada/gnatbind.adb
...@@ -36,7 +36,12 @@ with Debug; use Debug; ...@@ -36,7 +36,12 @@ with Debug; use Debug;
with Fmap; with Fmap;
with Namet; use Namet; with Namet; use Namet;
with Opt; use Opt; with Opt; use Opt;
with Osint; use Osint; 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 Osint.B; use Osint.B;
with Output; use Output; with Output; use Output;
with Rident; use Rident; with Rident; use Rident;
...@@ -47,10 +52,9 @@ with Targparm; use Targparm; ...@@ -47,10 +52,9 @@ with Targparm; use Targparm;
with Types; use Types; with Types; use Types;
with System.Case_Util; use System.Case_Util; with System.Case_Util; use System.Case_Util;
with System.Response_File;
with System.OS_Lib; use System.OS_Lib; with System.OS_Lib; use System.OS_Lib;
with Ada.Command_Line.Response_File; use Ada.Command_Line;
procedure Gnatbind is procedure Gnatbind is
Total_Errors : Nat := 0; Total_Errors : Nat := 0;
...@@ -505,8 +509,6 @@ procedure Gnatbind is ...@@ -505,8 +509,6 @@ procedure Gnatbind is
Next_Arg : Positive := 1; Next_Arg : Positive := 1;
begin begin
-- Use low level argument routines to avoid dragging in secondary stack
while Next_Arg < Arg_Count loop while Next_Arg < Arg_Count loop
declare declare
Next_Argv : String (1 .. Len_Arg (Next_Arg)); Next_Argv : String (1 .. Len_Arg (Next_Arg));
...@@ -519,7 +521,7 @@ procedure Gnatbind is ...@@ -519,7 +521,7 @@ procedure Gnatbind is
if Next_Argv'Length > 1 then if Next_Argv'Length > 1 then
declare declare
Arguments : constant Argument_List := Arguments : constant Argument_List :=
Response_File.Arguments_From System.Response_File.Arguments_From
(Response_File_Name => (Response_File_Name =>
Next_Argv (2 .. Next_Argv'Last), Next_Argv (2 .. Next_Argv'Last),
Recursive => True, Recursive => True,
...@@ -598,7 +600,13 @@ begin ...@@ -598,7 +600,13 @@ begin
Scan_Bind_Args; Scan_Bind_Args;
if Verbose_Mode then 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; Put_Bind_Args;
Write_Eol; Write_Eol;
end if; end if;
...@@ -669,7 +677,7 @@ begin ...@@ -669,7 +677,7 @@ begin
-- Output usage information if no arguments -- Output usage information if no arguments
if not More_Lib_Files then if not More_Lib_Files then
if Argument_Count = 0 then if Arg_Count = 0 then
Bindusg.Display; Bindusg.Display;
else else
Write_Line ("try ""gnatbind --help"" for more information."); Write_Line ("try ""gnatbind --help"" for more information.");
......
gcc/ada/s-diflio.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -30,7 +30,7 @@ ...@@ -30,7 +30,7 @@
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This package provides output routines for float dimensioned types. All Put -- 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 -- addition of an extra default parameter. All Put_Dim_Of routines
-- output the dimension of Item in a symbolic manner. -- output the dimension of Item in a symbolic manner.
......
gcc/ada/s-diinio.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -30,7 +30,7 @@ ...@@ -30,7 +30,7 @@
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- This package provides output routines for integer dimensioned types. All -- 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 -- with the addition of an extra default parameter. All Put_Dim_Of routines
-- output the dimension of Item in a symbolic manner. -- output the dimension of Item in a symbolic manner.
......
gcc/ada/s-resfil.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-resfil.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/sem_ch4.adb
...@@ -283,7 +283,7 @@ package body Sem_Ch4 is ...@@ -283,7 +283,7 @@ package body Sem_Ch4 is
-- Called when P is the prefix of an implicit dereference, denoting an -- Called when P is the prefix of an implicit dereference, denoting an
-- object E. The function returns the designated type of the prefix, taking -- 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 -- 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 -- 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 -- that the prefix is a reference to E, if any. Normally, such a reference
...@@ -755,7 +755,7 @@ package body Sem_Ch4 is ...@@ -755,7 +755,7 @@ package body Sem_Ch4 is
("\constraint with discriminant values required", N); ("\constraint with discriminant values required", N);
end if; end if;
-- Limited Ada 2005 and general non-limited case -- Limited Ada 2005 and general nonlimited case
else else
Error_Msg_N Error_Msg_N
...@@ -1469,10 +1469,10 @@ package body Sem_Ch4 is ...@@ -1469,10 +1469,10 @@ package body Sem_Ch4 is
-- can also happen when the function declaration appears before the -- can also happen when the function declaration appears before the
-- full view of the type (which is legal in Ada 2012) and the call -- 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 -- 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/ -- to prevent subsequent type errors. Note that the usual install/
-- removal of limited_with clauses is not sufficient to handle this -- 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. -- compilation unit that defines the current function.
if Is_Incomplete_Type (Etype (N)) then if Is_Incomplete_Type (Etype (N)) then
...@@ -4582,7 +4582,7 @@ package body Sem_Ch4 is ...@@ -4582,7 +4582,7 @@ package body Sem_Ch4 is
-- in what follows, either to retrieve a component of to find -- in what follows, either to retrieve a component of to find
-- a primitive operation. If the prefix is an explicit dereference, -- a primitive operation. If the prefix is an explicit dereference,
-- set the type of the prefix to reflect this transformation. -- 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. -- full view if available.
if From_Limited_With (Prefix_Type) if From_Limited_With (Prefix_Type)
...@@ -9012,7 +9012,7 @@ package body Sem_Ch4 is ...@@ -9012,7 +9012,7 @@ package body Sem_Ch4 is
-- The type may have be obtained through a limited_with clause, -- The type may have be obtained through a limited_with clause,
-- in which case the primitive operations are available on its -- 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 if Ekind (Obj_Type) = E_Incomplete_Type
and then From_Limited_With (Obj_Type) and then From_Limited_With (Obj_Type)
......
gcc/ada/sem_res.adb
...@@ -6630,11 +6630,15 @@ package body Sem_Res is ...@@ -6630,11 +6630,15 @@ package body Sem_Res is
null; null;
-- Calls cannot be inlined inside assertions, as GNATprove treats -- 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 elsif In_Assertion_Expr /= 0 then
Cannot_Inline if Present (Body_Id) then
("cannot inline & (in assertion expression)?", N, Nam_UA); Cannot_Inline
("cannot inline & (in assertion expression)?", N, Nam_UA);
end if;
-- Calls cannot be inlined inside default expressions -- Calls cannot be inlined inside default expressions
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment