gcc/ada/libgnat/s-resfil.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                  S Y S T E M . R E S P O N S E _ F I L E                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2007-2017, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 pragma Compiler_Unit_Warning;
  33
  34 with Ada.Unchecked_Deallocation;
  35
  36 with System.OS_Lib; use System.OS_Lib;
  37
  38 package body System.Response_File is
  39
  40    type File_Rec;
  41    type File_Ptr is access File_Rec;
  42    type File_Rec is record
  43       Name : String_Access;
  44       Next : File_Ptr;
  45       Prev : File_Ptr;
  46    end record;
  47    --  To build a stack of response file names
  48
  49    procedure Free is new Ada.Unchecked_Deallocation (File_Rec, File_Ptr);
  50
  51    type Argument_List_Access is access Argument_List;
  52    procedure Free is new Ada.Unchecked_Deallocation
  53      (Argument_List, Argument_List_Access);
  54    --  Free only the allocated Argument_List, not allocated String components
  55
  56    --------------------
  57    -- Arguments_From --
  58    --------------------
  59
  60    function Arguments_From
  61      (Response_File_Name        : String;
  62       Recursive                 : Boolean := False;
  63       Ignore_Non_Existing_Files : Boolean := False)
  64       return Argument_List
  65    is
  66       First_File : File_Ptr := null;
  67       Last_File  : File_Ptr := null;
  68       --  The stack of response files
  69
  70       Arguments  : Argument_List_Access := new Argument_List (1 .. 4);
  71       Last_Arg   : Natural := 0;
  72
  73       procedure Add_Argument (Arg : String);
  74       --  Add argument Arg to argument list Arguments, increasing Arguments
  75       --  if necessary.
  76
  77       procedure Recurse (File_Name : String);
  78       --  Get the arguments from the file and call itself recursively if one of
  79       --  the arguments starts with character '@'.
  80
  81       ------------------
  82       -- Add_Argument --
  83       ------------------
  84
  85       procedure Add_Argument (Arg : String) is
  86       begin
  87          if Last_Arg = Arguments'Last then
  88             declare
  89                New_Arguments : constant Argument_List_Access :=
  90                  new Argument_List (1 .. Arguments'Last * 2);
  91             begin
  92                New_Arguments (Arguments'Range) := Arguments.all;
  93                Arguments.all := (others => null);
  94                Free (Arguments);
  95                Arguments := New_Arguments;
  96             end;
  97          end if;
  98
  99          Last_Arg := Last_Arg + 1;
 100          Arguments (Last_Arg) := new String'(Arg);
 101       end Add_Argument;
 102
 103       -------------
 104       -- Recurse --
 105       -------------
 106
 107       procedure Recurse (File_Name : String) is
 108          --  Open the response file. If not found, fail or report a warning,
 109          --  depending on the value of Ignore_Non_Existing_Files.
 110
 111          FD : constant File_Descriptor := Open_Read (File_Name, Text);
 112
 113          Buffer_Size : constant := 1500;
 114          Buffer : String (1 .. Buffer_Size);
 115
 116          Buffer_Length : Natural;
 117
 118          Buffer_Cursor : Natural;
 119
 120          End_Of_File_Reached : Boolean;
 121
 122          Line : String (1 .. Max_Line_Length + 1);
 123          Last : Natural;
 124
 125          First_Char : Positive;
 126          --  Index of the first character of an argument in Line
 127
 128          Last_Char : Natural;
 129          --  Index of the last character of an argument in Line
 130
 131          In_String : Boolean;
 132          --  True when inside a quoted string
 133
 134          Arg : Positive;
 135
 136          function End_Of_File return Boolean;
 137          --  True when the end of the response file has been reached
 138
 139          procedure Get_Buffer;
 140          --  Read one buffer from the response file
 141
 142          procedure Get_Line;
 143          --  Get one line from the response file
 144
 145          -----------------
 146          -- End_Of_File --
 147          -----------------
 148
 149          function End_Of_File return Boolean is
 150          begin
 151             return End_Of_File_Reached and then Buffer_Cursor > Buffer_Length;
 152          end End_Of_File;
 153
 154          ----------------
 155          -- Get_Buffer --
 156          ----------------
 157
 158          procedure Get_Buffer is
 159          begin
 160             Buffer_Length := Read (FD, Buffer (1)'Address, Buffer'Length);
 161             End_Of_File_Reached := Buffer_Length < Buffer'Length;
 162             Buffer_Cursor := 1;
 163          end Get_Buffer;
 164
 165          --------------
 166          -- Get_Line --
 167          --------------
 168
 169          procedure Get_Line is
 170             Ch : Character;
 171
 172          begin
 173             Last := 0;
 174
 175             if End_Of_File then
 176                return;
 177             end if;
 178
 179             loop
 180                Ch := Buffer (Buffer_Cursor);
 181
 182                exit when Ch = ASCII.CR or else
 183                          Ch = ASCII.LF or else
 184                          Ch = ASCII.FF;
 185
 186                Last := Last + 1;
 187                Line (Last) := Ch;
 188
 189                if Last = Line'Last then
 190                   return;
 191                end if;
 192
 193                Buffer_Cursor := Buffer_Cursor + 1;
 194
 195                if Buffer_Cursor > Buffer_Length then
 196                   Get_Buffer;
 197
 198                   if End_Of_File then
 199                      return;
 200                   end if;
 201                end if;
 202             end loop;
 203
 204             loop
 205                Ch := Buffer (Buffer_Cursor);
 206
 207                exit when Ch /= ASCII.HT and then
 208                          Ch /= ASCII.LF and then
 209                          Ch /= ASCII.FF;
 210
 211                Buffer_Cursor := Buffer_Cursor + 1;
 212
 213                if Buffer_Cursor > Buffer_Length then
 214                   Get_Buffer;
 215
 216                   if End_Of_File then
 217                      return;
 218                   end if;
 219                end if;
 220             end loop;
 221          end Get_Line;
 222
 223       --  Start of processing for Recurse
 224
 225       begin
 226          Last_Arg := 0;
 227
 228          if FD = Invalid_FD then
 229             if Ignore_Non_Existing_Files then
 230                return;
 231             else
 232                raise File_Does_Not_Exist;
 233             end if;
 234          end if;
 235
 236          --  Put the response file name on the stack
 237
 238          if First_File = null then
 239             First_File :=
 240               new File_Rec'
 241                 (Name => new String'(File_Name),
 242                  Next => null,
 243                  Prev => null);
 244             Last_File  := First_File;
 245
 246          else
 247             declare
 248                Current : File_Ptr := First_File;
 249
 250             begin
 251                loop
 252                   if Current.Name.all = File_Name then
 253                      raise Circularity_Detected;
 254                   end if;
 255
 256                   Current := Current.Next;
 257                   exit when Current = null;
 258                end loop;
 259
 260                Last_File.Next :=
 261                  new File_Rec'
 262                    (Name => new String'(File_Name),
 263                     Next => null,
 264                     Prev => Last_File);
 265                Last_File := Last_File.Next;
 266             end;
 267          end if;
 268
 269          End_Of_File_Reached := False;
 270          Get_Buffer;
 271
 272          --  Read the response file line by line
 273
 274          Line_Loop :
 275          while not End_Of_File loop
 276             Get_Line;
 277
 278             if Last = Line'Last then
 279                raise Line_Too_Long;
 280             end if;
 281
 282             First_Char := 1;
 283
 284             --  Get each argument on the line
 285
 286             Arg_Loop :
 287             loop
 288                --  First, skip any white space
 289
 290                while First_Char <= Last loop
 291                   exit when Line (First_Char) /= ' ' and then
 292                             Line (First_Char) /= ASCII.HT;
 293                   First_Char := First_Char + 1;
 294                end loop;
 295
 296                exit Arg_Loop when First_Char > Last;
 297
 298                Last_Char := First_Char;
 299                In_String := False;
 300
 301                --  Get the character one by one
 302
 303                Character_Loop :
 304                while Last_Char <= Last loop
 305
 306                   --  Inside a string, check only for '"'
 307
 308                   if In_String then
 309                      if Line (Last_Char) = '"' then
 310
 311                         --  Remove the '"'
 312
 313                         Line (Last_Char .. Last - 1) :=
 314                           Line (Last_Char + 1 .. Last);
 315                         Last := Last - 1;
 316
 317                         --  End of string is end of argument
 318
 319                         if Last_Char > Last or else
 320                           Line (Last_Char) = ' ' or else
 321                           Line (Last_Char) = ASCII.HT
 322                         then
 323                            In_String := False;
 324
 325                            Last_Char := Last_Char - 1;
 326                            exit Character_Loop;
 327
 328                         else
 329                            --  If there are two consecutive '"', the quoted
 330                            --  string is not closed
 331
 332                            In_String := Line (Last_Char) = '"';
 333
 334                            if In_String then
 335                               Last_Char := Last_Char + 1;
 336                            end if;
 337                         end if;
 338
 339                      else
 340                         Last_Char := Last_Char + 1;
 341                      end if;
 342
 343                   elsif Last_Char = Last then
 344
 345                      --  An opening '"' at the end of the line is an error
 346
 347                      if Line (Last) = '"' then
 348                         raise No_Closing_Quote;
 349
 350                      else
 351                         --  The argument ends with the line
 352
 353                         exit Character_Loop;
 354                      end if;
 355
 356                   elsif Line (Last_Char) = '"' then
 357
 358                      --  Entering a quoted string: remove the '"'
 359
 360                      In_String := True;
 361                      Line (Last_Char .. Last - 1) :=
 362                        Line (Last_Char + 1 .. Last);
 363                      Last := Last - 1;
 364
 365                   else
 366                      --  Outside quoted strings, white space ends the argument
 367
 368                      exit Character_Loop
 369                           when Line (Last_Char + 1) = ' ' or else
 370                                Line (Last_Char + 1) = ASCII.HT;
 371
 372                      Last_Char := Last_Char + 1;
 373                   end if;
 374                end loop Character_Loop;
 375
 376                --  It is an error to not close a quoted string before the end
 377                --  of the line.
 378
 379                if In_String then
 380                   raise No_Closing_Quote;
 381                end if;
 382
 383                --  Add the argument to the list
 384
 385                declare
 386                   Arg : String (1 .. Last_Char - First_Char + 1);
 387                begin
 388                   Arg := Line (First_Char .. Last_Char);
 389                   Add_Argument (Arg);
 390                end;
 391
 392                --  Next argument, if line is not finished
 393
 394                First_Char := Last_Char + 1;
 395             end loop Arg_Loop;
 396          end loop Line_Loop;
 397
 398          Close (FD);
 399
 400          --  If Recursive is True, check for any argument starting with '@'
 401
 402          if Recursive then
 403             Arg := 1;
 404             while Arg <= Last_Arg loop
 405
 406                if Arguments (Arg)'Length > 0 and then
 407                   Arguments (Arg) (1) = '@'
 408                then
 409                   --  Ignore argument '@' with no file name
 410
 411                   if Arguments (Arg)'Length = 1 then
 412                      Arguments (Arg .. Last_Arg - 1) :=
 413                        Arguments (Arg + 1 .. Last_Arg);
 414                      Last_Arg := Last_Arg - 1;
 415
 416                   else
 417                      --  Save the current arguments and get those in the new
 418                      --  response file.
 419
 420                      declare
 421                         Inc_File_Name     : constant String :=
 422                           Arguments (Arg) (2 .. Arguments (Arg)'Last);
 423                         Current_Arguments : constant Argument_List :=
 424                           Arguments (1 .. Last_Arg);
 425                      begin
 426                         Recurse (Inc_File_Name);
 427
 428                         --  Insert the new arguments where the new response
 429                         --  file was imported.
 430
 431                         declare
 432                            New_Arguments : constant Argument_List :=
 433                              Arguments (1 .. Last_Arg);
 434                            New_Last_Arg  : constant Positive :=
 435                              Current_Arguments'Length +
 436                              New_Arguments'Length - 1;
 437
 438                         begin
 439                            --  Grow Arguments if it is not large enough
 440
 441                            if Arguments'Last < New_Last_Arg then
 442                               Last_Arg := Arguments'Last;
 443                               Free (Arguments);
 444
 445                               while Last_Arg < New_Last_Arg loop
 446                                  Last_Arg := Last_Arg * 2;
 447                               end loop;
 448
 449                               Arguments := new Argument_List (1 .. Last_Arg);
 450                            end if;
 451
 452                            Last_Arg := New_Last_Arg;
 453
 454                            Arguments (1 .. Last_Arg) :=
 455                              Current_Arguments (1 .. Arg - 1) &
 456                            New_Arguments &
 457                            Current_Arguments
 458                              (Arg + 1 .. Current_Arguments'Last);
 459
 460                            Arg := Arg + New_Arguments'Length;
 461                         end;
 462                      end;
 463                   end if;
 464
 465                else
 466                   Arg := Arg + 1;
 467                end if;
 468             end loop;
 469          end if;
 470
 471          --  Remove the response file name from the stack
 472
 473          if First_File = Last_File then
 474             System.Strings.Free (First_File.Name);
 475             Free (First_File);
 476             First_File := null;
 477             Last_File := null;
 478
 479          else
 480             System.Strings.Free (Last_File.Name);
 481             Last_File := Last_File.Prev;
 482             Free (Last_File.Next);
 483          end if;
 484
 485       exception
 486          when others =>
 487             Close (FD);
 488
 489             raise;
 490       end Recurse;
 491
 492    --  Start of processing for Arguments_From
 493
 494    begin
 495       --  The job is done by procedure Recurse
 496
 497       Recurse (Response_File_Name);
 498
 499       --  Free Arguments before returning the result
 500
 501       declare
 502          Result : constant Argument_List := Arguments (1 .. Last_Arg);
 503       begin
 504          Free (Arguments);
 505          return Result;
 506       end;
 507
 508    exception
 509       when others =>
 510
 511          --  When an exception occurs, deallocate everything
 512
 513          Free (Arguments);
 514
 515          while First_File /= null loop
 516             Last_File := First_File.Next;
 517             System.Strings.Free (First_File.Name);
 518             Free (First_File);
 519             First_File := Last_File;
 520          end loop;
 521
 522          raise;
 523    end Arguments_From;
 524
 525 end System.Response_File;