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) 2007, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Unchecked_Deallocation;
  35
  36 with System.OS_Lib; use System.OS_Lib;
  37
  38 package body Ada.Command_Line.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 argument 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          FD : File_Descriptor;
 109
 110          Buffer_Size : constant := 1500;
 111          Buffer : String (1 .. Buffer_Size);
 112
 113          Buffer_Length : Natural;
 114
 115          Buffer_Cursor : Natural;
 116
 117          End_Of_File_Reached : Boolean;
 118
 119          Line : String (1 .. Max_Line_Length + 1);
 120          Last : Natural;
 121
 122          First_Char : Positive;
 123          --  Index of the first character of an argument in Line
 124
 125          Last_Char : Natural;
 126          --  Index of the last character of an argument in Line
 127
 128          In_String : Boolean;
 129          --  True when inside a quoted string
 130
 131          Arg : Positive;
 132
 133          function End_Of_File return Boolean;
 134          --  True when the end of the response file has been reached
 135
 136          procedure Get_Buffer;
 137          --  Read one buffer from the response file
 138
 139          procedure Get_Line;
 140          --  Get one line from the response file
 141
 142          -----------------
 143          -- End_Of_File --
 144          -----------------
 145
 146          function End_Of_File return Boolean is
 147          begin
 148             return End_Of_File_Reached and then Buffer_Cursor > Buffer_Length;
 149          end End_Of_File;
 150
 151          ----------------
 152          -- Get_Buffer --
 153          ----------------
 154
 155          procedure Get_Buffer is
 156          begin
 157             Buffer_Length := Read (FD, Buffer (1)'Address, Buffer'Length);
 158             End_Of_File_Reached := Buffer_Length < Buffer'Length;
 159             Buffer_Cursor := 1;
 160          end Get_Buffer;
 161
 162          --------------
 163          -- Get_Line --
 164          --------------
 165
 166          procedure Get_Line is
 167             Ch : Character;
 168
 169          begin
 170             Last := 0;
 171
 172             if End_Of_File then
 173                return;
 174             end if;
 175
 176             loop
 177                Ch := Buffer (Buffer_Cursor);
 178
 179                exit when Ch = ASCII.CR or else
 180                          Ch = ASCII.LF or else
 181                          Ch = ASCII.FF;
 182
 183                Last := Last + 1;
 184                Line (Last) := Ch;
 185
 186                if Last = Line'Last then
 187                   return;
 188                end if;
 189
 190                Buffer_Cursor := Buffer_Cursor + 1;
 191
 192                if Buffer_Cursor > Buffer_Length then
 193                   Get_Buffer;
 194
 195                   if End_Of_File then
 196                      return;
 197                   end if;
 198                end if;
 199             end loop;
 200
 201             loop
 202                Ch := Buffer (Buffer_Cursor);
 203
 204                exit when Ch /= ASCII.HT and then
 205                          Ch /= ASCII.LF and then
 206                          Ch /= ASCII.FF;
 207
 208                Buffer_Cursor := Buffer_Cursor + 1;
 209
 210                if Buffer_Cursor > Buffer_Length then
 211                   Get_Buffer;
 212
 213                   if End_Of_File then
 214                      return;
 215                   end if;
 216                end if;
 217             end loop;
 218          end Get_Line;
 219
 220       --  Start or Recurse
 221
 222       begin
 223          Last_Arg := 0;
 224
 225          --  Open the response file. If not found, fail or report a warning,
 226          --  depending on the value of Ignore_Non_Existing_Files.
 227
 228          FD := Open_Read (File_Name, Text);
 229
 230          if FD = Invalid_FD then
 231             if Ignore_Non_Existing_Files then
 232                return;
 233             else
 234                raise File_Does_Not_Exist;
 235             end if;
 236          end if;
 237
 238          --  Put the response file name on the stack
 239
 240          if First_File = null then
 241             First_File :=
 242               new File_Rec'
 243                 (Name => new String'(File_Name),
 244                  Next => null,
 245                  Prev => null);
 246             Last_File  := First_File;
 247
 248          else
 249             declare
 250                Current : File_Ptr := First_File;
 251
 252             begin
 253                loop
 254                   if Current.Name.all = File_Name then
 255                      raise Circularity_Detected;
 256                   end if;
 257
 258                   Current := Current.Next;
 259                   exit when Current = null;
 260                end loop;
 261
 262                Last_File.Next :=
 263                  new File_Rec'
 264                    (Name => new String'(File_Name),
 265                     Next => null,
 266                     Prev => Last_File);
 267                Last_File := Last_File.Next;
 268             end;
 269          end if;
 270
 271          End_Of_File_Reached := False;
 272          Get_Buffer;
 273
 274          --  Read the response file line by line
 275
 276          Line_Loop :
 277          while not End_Of_File loop
 278             Get_Line;
 279
 280             if Last = Line'Last then
 281                raise Line_Too_Long;
 282             end if;
 283
 284             First_Char := 1;
 285
 286             --  Get each argument on the line
 287
 288             Arg_Loop :
 289             loop
 290                --  First, skip any white space
 291
 292                while First_Char <= Last loop
 293                   exit when Line (First_Char) /= ' ' and then
 294                             Line (First_Char) /= ASCII.HT;
 295                   First_Char := First_Char + 1;
 296                end loop;
 297
 298                exit Arg_Loop when First_Char > Last;
 299
 300                Last_Char := First_Char;
 301                In_String := False;
 302
 303                --  Get the character one by one
 304
 305                Character_Loop :
 306                while Last_Char <= Last loop
 307
 308                   --  Inside a string, check only for '"'
 309
 310                   if In_String then
 311                      if Line (Last_Char) = '"' then
 312
 313                         --  Remove the '"'
 314
 315                         Line (Last_Char .. Last - 1) :=
 316                           Line (Last_Char + 1 .. Last);
 317                         Last := Last - 1;
 318
 319                         --  End of string is end of argument
 320
 321                         if Last_Char > Last or else
 322                           Line (Last_Char) = ' ' or else
 323                           Line (Last_Char) = ASCII.HT
 324                         then
 325                            In_String := False;
 326
 327                            Last_Char := Last_Char - 1;
 328                            exit Character_Loop;
 329
 330                         else
 331                            --  If there are two consecutive '"', the quoted
 332                            --  string is not closed
 333
 334                            In_String := Line (Last_Char) = '"';
 335
 336                            if In_String then
 337                               Last_Char := Last_Char + 1;
 338                            end if;
 339                         end if;
 340
 341                      else
 342                         Last_Char := Last_Char + 1;
 343                      end if;
 344
 345                   elsif Last_Char = Last then
 346
 347                      --  An opening '"' at the end of the line is an error
 348
 349                      if Line (Last) = '"' then
 350                         raise No_Closing_Quote;
 351
 352                      else
 353                         --  The argument ends with the line
 354
 355                         exit Character_Loop;
 356                      end if;
 357
 358                   elsif Line (Last_Char) = '"' then
 359
 360                      --  Entering a quoted string: remove the '"'
 361
 362                      In_String := True;
 363                      Line (Last_Char .. Last - 1) :=
 364                        Line (Last_Char + 1 .. Last);
 365                      Last := Last - 1;
 366
 367                   else
 368                      --  Outside quoted strings, white space ends the argument
 369
 370                      exit Character_Loop
 371                           when Line (Last_Char + 1) = ' ' or else
 372                                Line (Last_Char + 1) = ASCII.HT;
 373
 374                      Last_Char := Last_Char + 1;
 375                   end if;
 376                end loop Character_Loop;
 377
 378                --  It is an error to not close a quoted string before the end
 379                --  of the line.
 380
 381                if In_String then
 382                   raise No_Closing_Quote;
 383                end if;
 384
 385                --  Add the argument to the list
 386
 387                declare
 388                   Arg : String (1 .. Last_Char - First_Char + 1);
 389                begin
 390                   Arg := Line (First_Char .. Last_Char);
 391                   Add_Argument (Arg);
 392                end;
 393
 394                --  Next argument, if line is not finished
 395
 396                First_Char := Last_Char + 1;
 397             end loop Arg_Loop;
 398          end loop Line_Loop;
 399
 400          Close (FD);
 401
 402          --  If Recursive is True, check for any argument starting with '@'
 403
 404          if Recursive then
 405             Arg := 1;
 406             while Arg <= Last_Arg loop
 407
 408                if Arguments (Arg)'Length > 0 and then
 409                   Arguments (Arg) (1) = '@'
 410                then
 411                   --  Ignore argument "@" with no file name
 412
 413                   if Arguments (Arg)'Length = 1 then
 414                      Arguments (Arg .. Last_Arg - 1) :=
 415                        Arguments (Arg + 1 .. Last_Arg);
 416                      Last_Arg := Last_Arg - 1;
 417
 418                   else
 419                      --  Save the current arguments and get those in the new
 420                      --  response file.
 421
 422                      declare
 423                         Inc_File_Name     : constant String :=
 424                                               Arguments (Arg)
 425                                               (2 .. Arguments (Arg)'Last);
 426                         Current_Arguments : constant Argument_List :=
 427                                               Arguments (1 .. Last_Arg);
 428                      begin
 429                         Recurse (Inc_File_Name);
 430
 431                         --  Insert the new arguments where the new response
 432                         --  file was imported.
 433
 434                         declare
 435                            New_Arguments : constant Argument_List :=
 436                                              Arguments (1 .. Last_Arg);
 437                            New_Last_Arg  : constant Positive :=
 438                                              Current_Arguments'Length +
 439                                              New_Arguments'Length - 1;
 440
 441                         begin
 442                            --  Grow Arguments if it is not large enough
 443
 444                            if Arguments'Last < New_Last_Arg then
 445                               Last_Arg := Arguments'Last;
 446                               Free (Arguments);
 447
 448                               while Last_Arg < New_Last_Arg loop
 449                                  Last_Arg := Last_Arg * 2;
 450                               end loop;
 451
 452                               Arguments := new Argument_List (1 .. Last_Arg);
 453                            end if;
 454
 455                            Last_Arg := New_Last_Arg;
 456
 457                            Arguments (1 .. Last_Arg) :=
 458                              Current_Arguments (1 .. Arg - 1) &
 459                            New_Arguments &
 460                            Current_Arguments
 461                              (Arg + 1 .. Current_Arguments'Last);
 462
 463                            Arg := Arg + New_Arguments'Length;
 464                         end;
 465                      end;
 466                   end if;
 467
 468                else
 469                   Arg := Arg + 1;
 470                end if;
 471             end loop;
 472          end if;
 473
 474          --  Remove the response file name from the stack
 475
 476          if First_File = Last_File then
 477             System.Strings.Free (First_File.Name);
 478             Free (First_File);
 479             First_File := null;
 480             Last_File := null;
 481
 482          else
 483             System.Strings.Free (Last_File.Name);
 484             Last_File := Last_File.Prev;
 485             Free (Last_File.Next);
 486          end if;
 487
 488       exception
 489          when others =>
 490             Close (FD);
 491
 492             raise;
 493       end Recurse;
 494
 495    --  Start of Arguments_From
 496
 497    begin
 498       --  The job is done by procedure Recurse
 499
 500       Recurse (Response_File_Name);
 501
 502       --  Free Arguments before returning the result
 503
 504       declare
 505          Result : constant Argument_List := Arguments (1 .. Last_Arg);
 506       begin
 507          Free (Arguments);
 508          return Result;
 509       end;
 510
 511    exception
 512       when others =>
 513
 514          --  When an exception occurs, deallocate everything
 515
 516          Free (Arguments);
 517
 518          while First_File /= null loop
 519             Last_File := First_File.Next;
 520             System.Strings.Free (First_File.Name);
 521             Free (First_File);
 522             First_File := Last_File;
 523          end loop;
 524
 525          raise;
 526    end Arguments_From;
 527
 528 end Ada.Command_Line.Response_File;