From: Arnaud Charlet Date: Wed, 6 Sep 2017 10:38:38 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=a316b3fcd05624ce0aadca3478f6a3c7b494c2d0;p=gcc.git [multiple changes] 2017-09-06 Gary Dismukes * exp_ch5.adb, s-diinio.ads, sem_ch4.adb, s-diflio.ads: Minor spelling adjustments and a typo fix. 2017-09-06 Yannick Moy * 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 * 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 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 19d518ed906..0d3f844d321 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,31 @@ +2017-09-06 Gary Dismukes + + * exp_ch5.adb, s-diinio.ads, sem_ch4.adb, s-diflio.ads: Minor spelling + adjustments and a typo fix. + +2017-09-06 Yannick Moy + + * 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 + + * 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 * frontend.adb (Frontend): Skip -gnatec=gnat.adc diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 611b09b1b6e..4eb60b536dc 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -1,5 +1,5 @@ # 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. @@ -651,6 +651,7 @@ GNATRTL_NONTASKING_OBJS= \ s-ransee$(objext) \ s-regexp$(objext) \ s-regpat$(objext) \ + s-resfil$(objext) \ s-restri$(objext) \ s-rident$(objext) \ s-rpc$(objext) \ diff --git a/gcc/ada/a-clrefi.adb b/gcc/ada/a-clrefi.adb index 914d8f4a013..71d05ff7735 100644 --- a/gcc/ada/a-clrefi.adb +++ b/gcc/ada/a-clrefi.adb @@ -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; - -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; diff --git a/gcc/ada/a-clrefi.ads b/gcc/ada/a-clrefi.ads index f4ce6df2b0c..14971f320e3 100644 --- a/gcc/ada/a-clrefi.ads +++ b/gcc/ada/a-clrefi.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -29,72 +29,7 @@ -- -- ------------------------------------------------------------------------------ --- 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; diff --git a/gcc/ada/a-comlin.adb b/gcc/ada/a-comlin.adb index 07905b80e63..2af8bd9e7ac 100644 --- a/gcc/ada/a-comlin.adb +++ b/gcc/ada/a-comlin.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -29,8 +29,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Compiler_Unit_Warning; - with System; use System; package body Ada.Command_Line is @@ -58,25 +56,12 @@ 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; -------------------- diff --git a/gcc/ada/a-comlin.ads b/gcc/ada/a-comlin.ads index 18695e91c30..b8e556270c2 100644 --- a/gcc/ada/a-comlin.ads +++ b/gcc/ada/a-comlin.ads @@ -33,8 +33,6 @@ -- -- ------------------------------------------------------------------------------ -pragma Compiler_Unit_Warning; - package Ada.Command_Line is pragma Preelaborate; @@ -45,14 +43,8 @@ package Ada.Command_Line is -- -- 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 diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 63cc4592967..981137d4309 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -3957,7 +3957,7 @@ package body Exp_Ch5 is -- 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)) /= diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index fa04e80a52d..e38a1f9e06f 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -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 GNATBIND_OBJS = \ - ada/a-clrefi.o \ - ada/a-comlin.o \ ada/a-elchha.o \ ada/a-except.o \ ada/ada.o \ @@ -553,6 +551,7 @@ GNATBIND_OBJS = \ 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 \ diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 6c778bb597e..63e79652143 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -36,7 +36,12 @@ with Debug; use Debug; 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; @@ -47,10 +52,9 @@ with Targparm; use Targparm; 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; @@ -505,8 +509,6 @@ procedure Gnatbind is 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)); @@ -519,7 +521,7 @@ procedure Gnatbind is 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, @@ -598,7 +600,13 @@ begin 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; @@ -669,7 +677,7 @@ begin -- 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."); diff --git a/gcc/ada/s-diflio.ads b/gcc/ada/s-diflio.ads index df550929ea3..223f5a23712 100644 --- a/gcc/ada/s-diflio.ads +++ b/gcc/ada/s-diflio.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -30,7 +30,7 @@ ------------------------------------------------------------------------------ -- 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. diff --git a/gcc/ada/s-diinio.ads b/gcc/ada/s-diinio.ads index e5e8c444cad..babcc166b11 100644 --- a/gcc/ada/s-diinio.ads +++ b/gcc/ada/s-diinio.ads @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -30,7 +30,7 @@ ------------------------------------------------------------------------------ -- 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. diff --git a/gcc/ada/s-resfil.adb b/gcc/ada/s-resfil.adb new file mode 100644 index 00000000000..b36ff944592 --- /dev/null +++ b/gcc/ada/s-resfil.adb @@ -0,0 +1,525 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/s-resfil.ads b/gcc/ada/s-resfil.ads new file mode 100644 index 00000000000..fbb7f7af09f --- /dev/null +++ b/gcc/ada/s-resfil.ads @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 8952a9ef7e5..b02d72bc509 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -283,7 +283,7 @@ package body Sem_Ch4 is -- 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 @@ -755,7 +755,7 @@ package body Sem_Ch4 is ("\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 @@ -1469,10 +1469,10 @@ package body Sem_Ch4 is -- 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 @@ -4582,7 +4582,7 @@ package body Sem_Ch4 is -- 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) @@ -9012,7 +9012,7 @@ package body Sem_Ch4 is -- 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) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 6c0d1a7a093..ea5618f383d 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6630,11 +6630,15 @@ package body Sem_Res is 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