gcc/ada/a-clrefi.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --       A D A . C O M M A N D _ L I N E . R E S P O N S E _ F I L E        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2009, 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 with Ada.Unchecked_Deallocation;
  33
  34 with System.OS_Lib; use System.OS_Lib;
  35
  36 package body Ada.Command_Line.Response_File is
  37
  38    type File_Rec;
  39    type File_Ptr is access File_Rec;
  40    type File_Rec is record
  41       Name : String_Access;
  42       Next : File_Ptr;
  43       Prev : File_Ptr;
  44    end record;
  45    --  To build a stack of response file names
  46
  47    procedure Free is new Ada.Unchecked_Deallocation (File_Rec, File_Ptr);
  48
  49    type Argument_List_Access is access Argument_List;
  50    procedure Free is new Ada.Unchecked_Deallocation
  51      (Argument_List, Argument_List_Access);
  52    --  Free only the allocated Argument_List, not allocated String components
  53
  54    --------------------
  55    -- Arguments_From --
  56    --------------------
  57
  58    function Arguments_From
  59      (Response_File_Name        : String;
  60       Recursive                 : Boolean := False;
  61       Ignore_Non_Existing_Files : Boolean := False)
  62       return Argument_List
  63    is
  64       First_File : File_Ptr := null;
  65       Last_File  : File_Ptr := null;
  66       --  The stack of response files
  67
  68       Arguments  : Argument_List_Access := new Argument_List (1 .. 4);
  69       Last_Arg   : Natural := 0;
  70
  71       procedure Add_Argument (Arg : String);
  72       --  Add argument Arg to argument list Arguments, increasing Arguments
  73       --  if necessary.
  74
  75       procedure Recurse (File_Name : String);
  76       --  Get the arguments from the file and call itself recursively if one of
  77       --  the argument starts with character '@'.
  78
  79       ------------------
  80       -- Add_Argument --
  81       ------------------
  82
  83       procedure Add_Argument (Arg : String) is
  84       begin
  85          if Last_Arg = Arguments'Last then
  86             declare
  87                New_Arguments : constant Argument_List_Access :=
  88                                  new Argument_List (1 .. Arguments'Last * 2);
  89             begin
  90                New_Arguments (Arguments'Range) := Arguments.all;
  91                Arguments.all := (others => null);
  92                Free (Arguments);
  93                Arguments := New_Arguments;
  94             end;
  95          end if;
  96
  97          Last_Arg := Last_Arg + 1;
  98          Arguments (Last_Arg) := new String'(Arg);
  99       end Add_Argument;
 100
 101       -------------
 102       -- Recurse --
 103       -------------
 104
 105       procedure Recurse (File_Name : String) is
 106          FD : File_Descriptor;
 107
 108          Buffer_Size : constant := 1500;
 109          Buffer : String (1 .. Buffer_Size);
 110
 111          Buffer_Length : Natural;
 112
 113          Buffer_Cursor : Natural;
 114
 115          End_Of_File_Reached : Boolean;
 116
 117          Line : String (1 .. Max_Line_Length + 1);
 118          Last : Natural;
 119
 120          First_Char : Positive;
 121          --  Index of the first character of an argument in Line
 122
 123          Last_Char : Natural;
 124          --  Index of the last character of an argument in Line
 125
 126          In_String : Boolean;
 127          --  True when inside a quoted string
 128
 129          Arg : Positive;
 130
 131          function End_Of_File return Boolean;
 132          --  True when the end of the response file has been reached
 133
 134          procedure Get_Buffer;
 135          --  Read one buffer from the response file
 136
 137          procedure Get_Line;
 138          --  Get one line from the response file
 139
 140          -----------------
 141          -- End_Of_File --
 142          -----------------
 143
 144          function End_Of_File return Boolean is
 145          begin
 146             return End_Of_File_Reached and then Buffer_Cursor > Buffer_Length;
 147          end End_Of_File;
 148
 149          ----------------
 150          -- Get_Buffer --
 151          ----------------
 152
 153          procedure Get_Buffer is
 154          begin
 155             Buffer_Length := Read (FD, Buffer (1)'Address, Buffer'Length);
 156             End_Of_File_Reached := Buffer_Length < Buffer'Length;
 157             Buffer_Cursor := 1;
 158          end Get_Buffer;
 159
 160          --------------
 161          -- Get_Line --
 162          --------------
 163
 164          procedure Get_Line is
 165             Ch : Character;
 166
 167          begin
 168             Last := 0;
 169
 170             if End_Of_File then
 171                return;
 172             end if;
 173
 174             loop
 175                Ch := Buffer (Buffer_Cursor);
 176
 177                exit when Ch = ASCII.CR or else
 178                          Ch = ASCII.LF or else
 179                          Ch = ASCII.FF;
 180
 181                Last := Last + 1;
 182                Line (Last) := Ch;
 183
 184                if Last = Line'Last then
 185                   return;
 186                end if;
 187
 188                Buffer_Cursor := Buffer_Cursor + 1;
 189
 190                if Buffer_Cursor > Buffer_Length then
 191                   Get_Buffer;
 192
 193                   if End_Of_File then
 194                      return;
 195                   end if;
 196                end if;
 197             end loop;
 198
 199             loop
 200                Ch := Buffer (Buffer_Cursor);
 201
 202                exit when Ch /= ASCII.HT and then
 203                          Ch /= ASCII.LF and then
 204                          Ch /= ASCII.FF;
 205
 206                Buffer_Cursor := Buffer_Cursor + 1;
 207
 208                if Buffer_Cursor > Buffer_Length then
 209                   Get_Buffer;
 210
 211                   if End_Of_File then
 212                      return;
 213                   end if;
 214                end if;
 215             end loop;
 216          end Get_Line;
 217
 218       --  Start or Recurse
 219
 220       begin
 221          Last_Arg := 0;
 222
 223          --  Open the response file. If not found, fail or report a warning,
 224          --  depending on the value of Ignore_Non_Existing_Files.
 225
 226          FD := Open_Read (File_Name, Text);
 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)
 423                                               (2 .. Arguments (Arg)'Last);
 424                         Current_Arguments : constant Argument_List :=
 425                                               Arguments (1 .. Last_Arg);
 426                      begin
 427                         Recurse (Inc_File_Name);
 428
 429                         --  Insert the new arguments where the new response
 430                         --  file was imported.
 431
 432                         declare
 433                            New_Arguments : constant Argument_List :=
 434                                              Arguments (1 .. Last_Arg);
 435                            New_Last_Arg  : constant Positive :=
 436                                              Current_Arguments'Length +
 437                                              New_Arguments'Length - 1;
 438
 439                         begin
 440                            --  Grow Arguments if it is not large enough
 441
 442                            if Arguments'Last < New_Last_Arg then
 443                               Last_Arg := Arguments'Last;
 444                               Free (Arguments);
 445
 446                               while Last_Arg < New_Last_Arg loop
 447                                  Last_Arg := Last_Arg * 2;
 448                               end loop;
 449
 450                               Arguments := new Argument_List (1 .. Last_Arg);
 451                            end if;
 452
 453                            Last_Arg := New_Last_Arg;
 454
 455                            Arguments (1 .. Last_Arg) :=
 456                              Current_Arguments (1 .. Arg - 1) &
 457                            New_Arguments &
 458                            Current_Arguments
 459                              (Arg + 1 .. Current_Arguments'Last);
 460
 461                            Arg := Arg + New_Arguments'Length;
 462                         end;
 463                      end;
 464                   end if;
 465
 466                else
 467                   Arg := Arg + 1;
 468                end if;
 469             end loop;
 470          end if;
 471
 472          --  Remove the response file name from the stack
 473
 474          if First_File = Last_File then
 475             System.Strings.Free (First_File.Name);
 476             Free (First_File);
 477             First_File := null;
 478             Last_File := null;
 479
 480          else
 481             System.Strings.Free (Last_File.Name);
 482             Last_File := Last_File.Prev;
 483             Free (Last_File.Next);
 484          end if;
 485
 486       exception
 487          when others =>
 488             Close (FD);
 489
 490             raise;
 491       end Recurse;
 492
 493    --  Start of Arguments_From
 494
 495    begin
 496       --  The job is done by procedure Recurse
 497
 498       Recurse (Response_File_Name);
 499
 500       --  Free Arguments before returning the result
 501
 502       declare
 503          Result : constant Argument_List := Arguments (1 .. Last_Arg);
 504       begin
 505          Free (Arguments);
 506          return Result;
 507       end;
 508
 509    exception
 510       when others =>
 511
 512          --  When an exception occurs, deallocate everything
 513
 514          Free (Arguments);
 515
 516          while First_File /= null loop
 517             Last_File := First_File.Next;
 518             System.Strings.Free (First_File.Name);
 519             Free (First_File);
 520             First_File := Last_File;
 521          end loop;
 522
 523          raise;
 524    end Arguments_From;
 525
 526 end Ada.Command_Line.Response_File;